diff --git a/exports/gensymbol b/exports/gensymbol
index e154b26bb..daedf8dcc 100644
--- a/exports/gensymbol
+++ b/exports/gensymbol
@@ -181,7 +181,7 @@
slaqtr, slar1v, slar2v, ilaslr, ilaslc,
slarf, slarfb, slarfg, slarfgp, slarft, slarfx, slargv,
slarrv, slartv,
- slarz, slarzb, slarzt, slasy2, slasyf,
+ slarz, slarzb, slarzt, slasy2, slasyf,
slatbs, slatdf, slatps, slatrd, slatrs, slatrz, slatzm,
sopgtr, sopmtr, sorg2l, sorg2r,
sorgbr, sorghr, sorgl2, sorglq, sorgql, sorgqr, sorgr2,
@@ -213,7 +213,8 @@
stfttr, stpttf, stpttr, strttf, strttp,
sgejsv, sgesvj, sgsvj0, sgsvj1,
sgeequb, ssyequb, spoequb, sgbequb,
- sbbcsd, slapmr, sorbdb, sorcsd,
+ sbbcsd, slapmr, sorbdb, sorbdb1, sorbdb2, sorbdb3, sorbdb4,
+ sorbdb5, sorbdb6, sorcsd, sorcsd2by1,
sgeqrt, sgeqrt2, sgeqrt3, sgemqrt,
stpqrt, stpqrt2, stpmqrt, stprfb,
@@ -288,7 +289,8 @@
chfrk, ctfttp, clanhf, cpftrf, cpftri, cpftrs, ctfsm, ctftri,
ctfttr, ctpttf, ctpttr, ctrttf, ctrttp,
cgeequb, cgbequb, csyequb, cpoequb, cheequb,
- cbbcsd, clapmr, cunbdb, cuncsd,
+ cbbcsd, clapmr, cunbdb, cunbdb1, cunbdb2, cunbdb3, cunbdb4,
+ cunbdb5, cunbdb6, cuncsd, cuncsd2by1,
cgeqrt, cgeqrt2, cgeqrt3, cgemqrt,
ctpqrt, ctpqrt2, ctpmqrt, ctprfb,
@@ -360,7 +362,8 @@
dtfttr, dtpttf, dtpttr, dtrttf, dtrttp,
dgejsv, dgesvj, dgsvj0, dgsvj1,
dgeequb, dsyequb, dpoequb, dgbequb,
- dbbcsd, dlapmr, dorbdb, dorcsd,
+ dbbcsd, dlapmr, dorbdb, dorbdb1, dorbdb2, dorbdb3, dorbdb4,
+ dorbdb5, dorbdb6, dorcsd, dorcsd2by1,
dgeqrt, dgeqrt2, dgeqrt3, dgemqrt,
dtpqrt, dtpqrt2, dtpmqrt, dtprfb,
@@ -433,7 +436,8 @@
zhfrk, ztfttp, zlanhf, zpftrf, zpftri, zpftrs, ztfsm, ztftri,
ztfttr, ztpttf, ztpttr, ztrttf, ztrttp,
zgeequb, zgbequb, zsyequb, zpoequb, zheequb,
- zbbcsd, zlapmr, zunbdb, zuncsd,
+ zbbcsd, zlapmr, zunbdb, zunbdb1, zunbdb2, zunbdb3, zunbdb4,
+ zunbdb5, zunbdb6, zuncsd, zuncsd2by1,
zgeqrt, zgeqrt2, zgeqrt3, zgemqrt,
ztpqrt, ztpqrt2, ztpmqrt, ztprfb,
);
@@ -603,1965 +607,1986 @@
lapack_make_complex_float,
lapack_make_complex_double,
- # @(SRC_OBJ) from `lapack-3.4.1/lapacke/src/Makefile`
- LAPACKE_cbbcsd,
- LAPACKE_cbbcsd_work,
- LAPACKE_cbdsqr,
- LAPACKE_cbdsqr_work,
- LAPACKE_cgbbrd,
- LAPACKE_cgbbrd_work,
- LAPACKE_cgbcon,
- LAPACKE_cgbcon_work,
- LAPACKE_cgbequ,
- LAPACKE_cgbequ_work,
- LAPACKE_cgbequb,
- LAPACKE_cgbequb_work,
- LAPACKE_cgbrfs,
- LAPACKE_cgbrfs_work,
- LAPACKE_cgbsv,
- LAPACKE_cgbsv_work,
- LAPACKE_cgbsvx,
- LAPACKE_cgbsvx_work,
- LAPACKE_cgbtrf,
- LAPACKE_cgbtrf_work,
- LAPACKE_cgbtrs,
- LAPACKE_cgbtrs_work,
- LAPACKE_cgebak,
- LAPACKE_cgebak_work,
- LAPACKE_cgebal,
- LAPACKE_cgebal_work,
- LAPACKE_cgebrd,
- LAPACKE_cgebrd_work,
- LAPACKE_cgecon,
- LAPACKE_cgecon_work,
- LAPACKE_cgeequ,
- LAPACKE_cgeequ_work,
- LAPACKE_cgeequb,
- LAPACKE_cgeequb_work,
- LAPACKE_cgees,
- LAPACKE_cgees_work,
- LAPACKE_cgeesx,
- LAPACKE_cgeesx_work,
- LAPACKE_cgeev,
- LAPACKE_cgeev_work,
- LAPACKE_cgeevx,
- LAPACKE_cgeevx_work,
- LAPACKE_cgehrd,
- LAPACKE_cgehrd_work,
- LAPACKE_cgelq2,
- LAPACKE_cgelq2_work,
- LAPACKE_cgelqf,
- LAPACKE_cgelqf_work,
- LAPACKE_cgels,
- LAPACKE_cgels_work,
- LAPACKE_cgelsd,
- LAPACKE_cgelsd_work,
- LAPACKE_cgelss,
- LAPACKE_cgelss_work,
- LAPACKE_cgelsy,
- LAPACKE_cgelsy_work,
- LAPACKE_cgemqrt,
- LAPACKE_cgemqrt_work,
- LAPACKE_cgeqlf,
- LAPACKE_cgeqlf_work,
- LAPACKE_cgeqp3,
- LAPACKE_cgeqp3_work,
- LAPACKE_cgeqpf,
- LAPACKE_cgeqpf_work,
- LAPACKE_cgeqr2,
- LAPACKE_cgeqr2_work,
- LAPACKE_cgeqrf,
- LAPACKE_cgeqrf_work,
- LAPACKE_cgeqrfp,
- LAPACKE_cgeqrfp_work,
- LAPACKE_cgeqrt,
- LAPACKE_cgeqrt2,
- LAPACKE_cgeqrt2_work,
- LAPACKE_cgeqrt3,
- LAPACKE_cgeqrt3_work,
- LAPACKE_cgeqrt_work,
- LAPACKE_cgerfs,
- LAPACKE_cgerfs_work,
- LAPACKE_cgerqf,
- LAPACKE_cgerqf_work,
- LAPACKE_cgesdd,
- LAPACKE_cgesdd_work,
- LAPACKE_cgesv,
- LAPACKE_cgesv_work,
- LAPACKE_cgesvd,
- LAPACKE_cgesvd_work,
- LAPACKE_cgesvx,
- LAPACKE_cgesvx_work,
- LAPACKE_cgetf2,
- LAPACKE_cgetf2_work,
- LAPACKE_cgetrf,
- LAPACKE_cgetrf_work,
- LAPACKE_cgetri,
- LAPACKE_cgetri_work,
- LAPACKE_cgetrs,
- LAPACKE_cgetrs_work,
- LAPACKE_cggbak,
- LAPACKE_cggbak_work,
- LAPACKE_cggbal,
- LAPACKE_cggbal_work,
- LAPACKE_cgges,
- LAPACKE_cgges_work,
- LAPACKE_cggesx,
- LAPACKE_cggesx_work,
- LAPACKE_cggev,
- LAPACKE_cggev_work,
- LAPACKE_cggevx,
- LAPACKE_cggevx_work,
- LAPACKE_cggglm,
- LAPACKE_cggglm_work,
- LAPACKE_cgghrd,
- LAPACKE_cgghrd_work,
- LAPACKE_cgglse,
- LAPACKE_cgglse_work,
- LAPACKE_cggqrf,
- LAPACKE_cggqrf_work,
- LAPACKE_cggrqf,
- LAPACKE_cggrqf_work,
- LAPACKE_cggsvd,
- LAPACKE_cggsvd_work,
- LAPACKE_cggsvp,
- LAPACKE_cggsvp_work,
- LAPACKE_cgtcon,
- LAPACKE_cgtcon_work,
- LAPACKE_cgtrfs,
- LAPACKE_cgtrfs_work,
- LAPACKE_cgtsv,
- LAPACKE_cgtsv_work,
- LAPACKE_cgtsvx,
- LAPACKE_cgtsvx_work,
- LAPACKE_cgttrf,
- LAPACKE_cgttrf_work,
- LAPACKE_cgttrs,
- LAPACKE_cgttrs_work,
- LAPACKE_chbev,
- LAPACKE_chbev_work,
- LAPACKE_chbevd,
- LAPACKE_chbevd_work,
- LAPACKE_chbevx,
- LAPACKE_chbevx_work,
- LAPACKE_chbgst,
- LAPACKE_chbgst_work,
- LAPACKE_chbgv,
- LAPACKE_chbgv_work,
- LAPACKE_chbgvd,
- LAPACKE_chbgvd_work,
- LAPACKE_chbgvx,
- LAPACKE_chbgvx_work,
- LAPACKE_chbtrd,
- LAPACKE_chbtrd_work,
- LAPACKE_checon,
- LAPACKE_checon_work,
- LAPACKE_cheequb,
- LAPACKE_cheequb_work,
- LAPACKE_cheev,
- LAPACKE_cheev_work,
- LAPACKE_cheevd,
- LAPACKE_cheevd_work,
- LAPACKE_cheevr,
- LAPACKE_cheevr_work,
- LAPACKE_cheevx,
- LAPACKE_cheevx_work,
- LAPACKE_chegst,
- LAPACKE_chegst_work,
- LAPACKE_chegv,
- LAPACKE_chegv_work,
- LAPACKE_chegvd,
- LAPACKE_chegvd_work,
- LAPACKE_chegvx,
- LAPACKE_chegvx_work,
- LAPACKE_cherfs,
- LAPACKE_cherfs_work,
- LAPACKE_chesv,
- LAPACKE_chesv_work,
- LAPACKE_chesvx,
- LAPACKE_chesvx_work,
- LAPACKE_cheswapr,
- LAPACKE_cheswapr_work,
- LAPACKE_chetrd,
- LAPACKE_chetrd_work,
- LAPACKE_chetrf,
- LAPACKE_chetrf_work,
- LAPACKE_chetri,
- LAPACKE_chetri2,
- LAPACKE_chetri2_work,
- LAPACKE_chetri2x,
- LAPACKE_chetri2x_work,
- LAPACKE_chetri_work,
- LAPACKE_chetrs,
- LAPACKE_chetrs2,
- LAPACKE_chetrs2_work,
- LAPACKE_chetrs_work,
- LAPACKE_chfrk,
- LAPACKE_chfrk_work,
- LAPACKE_chgeqz,
- LAPACKE_chgeqz_work,
- LAPACKE_chpcon,
- LAPACKE_chpcon_work,
- LAPACKE_chpev,
- LAPACKE_chpev_work,
- LAPACKE_chpevd,
- LAPACKE_chpevd_work,
- LAPACKE_chpevx,
- LAPACKE_chpevx_work,
- LAPACKE_chpgst,
- LAPACKE_chpgst_work,
- LAPACKE_chpgv,
- LAPACKE_chpgv_work,
- LAPACKE_chpgvd,
- LAPACKE_chpgvd_work,
- LAPACKE_chpgvx,
- LAPACKE_chpgvx_work,
- LAPACKE_chprfs,
- LAPACKE_chprfs_work,
- LAPACKE_chpsv,
- LAPACKE_chpsv_work,
- LAPACKE_chpsvx,
- LAPACKE_chpsvx_work,
- LAPACKE_chptrd,
- LAPACKE_chptrd_work,
- LAPACKE_chptrf,
- LAPACKE_chptrf_work,
- LAPACKE_chptri,
- LAPACKE_chptri_work,
- LAPACKE_chptrs,
- LAPACKE_chptrs_work,
- LAPACKE_chsein,
- LAPACKE_chsein_work,
- LAPACKE_chseqr,
- LAPACKE_chseqr_work,
- LAPACKE_clacgv,
- LAPACKE_clacgv_work,
- LAPACKE_clacpy,
- LAPACKE_clacpy_work,
- LAPACKE_clag2z,
- LAPACKE_clag2z_work,
- LAPACKE_clange,
- LAPACKE_clange_work,
- LAPACKE_clanhe,
- LAPACKE_clanhe_work,
- LAPACKE_clansy,
- LAPACKE_clansy_work,
- LAPACKE_clantr,
- LAPACKE_clantr_work,
- LAPACKE_clapmr,
- LAPACKE_clapmr_work,
- LAPACKE_clarfb,
- LAPACKE_clarfb_work,
- LAPACKE_clarfg,
- LAPACKE_clarfg_work,
- LAPACKE_clarft,
- LAPACKE_clarft_work,
- LAPACKE_clarfx,
- LAPACKE_clarfx_work,
- LAPACKE_clarnv,
- LAPACKE_clarnv_work,
- LAPACKE_claset,
- LAPACKE_claset_work,
- LAPACKE_claswp,
- LAPACKE_claswp_work,
- LAPACKE_clauum,
- LAPACKE_clauum_work,
- LAPACKE_cpbcon,
- LAPACKE_cpbcon_work,
- LAPACKE_cpbequ,
- LAPACKE_cpbequ_work,
- LAPACKE_cpbrfs,
- LAPACKE_cpbrfs_work,
- LAPACKE_cpbstf,
- LAPACKE_cpbstf_work,
- LAPACKE_cpbsv,
- LAPACKE_cpbsv_work,
- LAPACKE_cpbsvx,
- LAPACKE_cpbsvx_work,
- LAPACKE_cpbtrf,
- LAPACKE_cpbtrf_work,
- LAPACKE_cpbtrs,
- LAPACKE_cpbtrs_work,
- LAPACKE_cpftrf,
- LAPACKE_cpftrf_work,
- LAPACKE_cpftri,
- LAPACKE_cpftri_work,
- LAPACKE_cpftrs,
- LAPACKE_cpftrs_work,
- LAPACKE_cpocon,
- LAPACKE_cpocon_work,
- LAPACKE_cpoequ,
- LAPACKE_cpoequ_work,
- LAPACKE_cpoequb,
- LAPACKE_cpoequb_work,
- LAPACKE_cporfs,
- LAPACKE_cporfs_work,
- LAPACKE_cposv,
- LAPACKE_cposv_work,
- LAPACKE_cposvx,
- LAPACKE_cposvx_work,
- LAPACKE_cpotrf,
- LAPACKE_cpotrf_work,
- LAPACKE_cpotri,
- LAPACKE_cpotri_work,
- LAPACKE_cpotrs,
- LAPACKE_cpotrs_work,
- LAPACKE_cppcon,
- LAPACKE_cppcon_work,
- LAPACKE_cppequ,
- LAPACKE_cppequ_work,
- LAPACKE_cpprfs,
- LAPACKE_cpprfs_work,
- LAPACKE_cppsv,
- LAPACKE_cppsv_work,
- LAPACKE_cppsvx,
- LAPACKE_cppsvx_work,
- LAPACKE_cpptrf,
- LAPACKE_cpptrf_work,
- LAPACKE_cpptri,
- LAPACKE_cpptri_work,
- LAPACKE_cpptrs,
- LAPACKE_cpptrs_work,
- LAPACKE_cpstrf,
- LAPACKE_cpstrf_work,
- LAPACKE_cptcon,
- LAPACKE_cptcon_work,
- LAPACKE_cpteqr,
- LAPACKE_cpteqr_work,
- LAPACKE_cptrfs,
- LAPACKE_cptrfs_work,
- LAPACKE_cptsv,
- LAPACKE_cptsv_work,
- LAPACKE_cptsvx,
- LAPACKE_cptsvx_work,
- LAPACKE_cpttrf,
- LAPACKE_cpttrf_work,
- LAPACKE_cpttrs,
- LAPACKE_cpttrs_work,
- LAPACKE_cspcon,
- LAPACKE_cspcon_work,
- LAPACKE_csprfs,
- LAPACKE_csprfs_work,
- LAPACKE_cspsv,
- LAPACKE_cspsv_work,
- LAPACKE_cspsvx,
- LAPACKE_cspsvx_work,
- LAPACKE_csptrf,
- LAPACKE_csptrf_work,
- LAPACKE_csptri,
- LAPACKE_csptri_work,
- LAPACKE_csptrs,
- LAPACKE_csptrs_work,
- LAPACKE_cstedc,
- LAPACKE_cstedc_work,
- LAPACKE_cstegr,
- LAPACKE_cstegr_work,
- LAPACKE_cstein,
- LAPACKE_cstein_work,
- LAPACKE_cstemr,
- LAPACKE_cstemr_work,
- LAPACKE_csteqr,
- LAPACKE_csteqr_work,
- LAPACKE_csycon,
- LAPACKE_csycon_work,
- LAPACKE_csyconv,
- LAPACKE_csyconv_work,
- LAPACKE_csyequb,
- LAPACKE_csyequb_work,
- LAPACKE_csyrfs,
- LAPACKE_csyrfs_work,
- LAPACKE_csysv,
- LAPACKE_csysv_work,
- LAPACKE_csysvx,
- LAPACKE_csysvx_work,
- LAPACKE_csyswapr,
- LAPACKE_csyswapr_work,
- LAPACKE_csytrf,
- LAPACKE_csytrf_work,
- LAPACKE_csytri,
- LAPACKE_csytri2,
- LAPACKE_csytri2_work,
- LAPACKE_csytri2x,
- LAPACKE_csytri2x_work,
- LAPACKE_csytri_work,
- LAPACKE_csytrs,
- LAPACKE_csytrs2,
- LAPACKE_csytrs2_work,
- LAPACKE_csytrs_work,
- LAPACKE_ctbcon,
- LAPACKE_ctbcon_work,
- LAPACKE_ctbrfs,
- LAPACKE_ctbrfs_work,
- LAPACKE_ctbtrs,
- LAPACKE_ctbtrs_work,
- LAPACKE_ctfsm,
- LAPACKE_ctfsm_work,
- LAPACKE_ctftri,
- LAPACKE_ctftri_work,
- LAPACKE_ctfttp,
- LAPACKE_ctfttp_work,
- LAPACKE_ctfttr,
- LAPACKE_ctfttr_work,
- LAPACKE_ctgevc,
- LAPACKE_ctgevc_work,
- LAPACKE_ctgexc,
- LAPACKE_ctgexc_work,
- LAPACKE_ctgsen,
- LAPACKE_ctgsen_work,
- LAPACKE_ctgsja,
- LAPACKE_ctgsja_work,
- LAPACKE_ctgsna,
- LAPACKE_ctgsna_work,
- LAPACKE_ctgsyl,
- LAPACKE_ctgsyl_work,
- LAPACKE_ctpcon,
- LAPACKE_ctpcon_work,
- LAPACKE_ctpmqrt,
- LAPACKE_ctpmqrt_work,
- LAPACKE_ctpqrt,
- LAPACKE_ctpqrt2,
- LAPACKE_ctpqrt2_work,
- LAPACKE_ctpqrt_work,
- LAPACKE_ctprfb,
- LAPACKE_ctprfb_work,
- LAPACKE_ctprfs,
- LAPACKE_ctprfs_work,
- LAPACKE_ctptri,
- LAPACKE_ctptri_work,
- LAPACKE_ctptrs,
- LAPACKE_ctptrs_work,
- LAPACKE_ctpttf,
- LAPACKE_ctpttf_work,
- LAPACKE_ctpttr,
- LAPACKE_ctpttr_work,
- LAPACKE_ctrcon,
- LAPACKE_ctrcon_work,
- LAPACKE_ctrevc,
- LAPACKE_ctrevc_work,
- LAPACKE_ctrexc,
- LAPACKE_ctrexc_work,
- LAPACKE_ctrrfs,
- LAPACKE_ctrrfs_work,
- LAPACKE_ctrsen,
- LAPACKE_ctrsen_work,
- LAPACKE_ctrsna,
- LAPACKE_ctrsna_work,
- LAPACKE_ctrsyl,
- LAPACKE_ctrsyl_work,
- LAPACKE_ctrtri,
- LAPACKE_ctrtri_work,
- LAPACKE_ctrtrs,
- LAPACKE_ctrtrs_work,
- LAPACKE_ctrttf,
- LAPACKE_ctrttf_work,
- LAPACKE_ctrttp,
- LAPACKE_ctrttp_work,
- LAPACKE_ctzrzf,
- LAPACKE_ctzrzf_work,
- LAPACKE_cunbdb,
- LAPACKE_cunbdb_work,
- LAPACKE_cuncsd,
- LAPACKE_cuncsd_work,
- LAPACKE_cungbr,
- LAPACKE_cungbr_work,
- LAPACKE_cunghr,
- LAPACKE_cunghr_work,
- LAPACKE_cunglq,
- LAPACKE_cunglq_work,
- LAPACKE_cungql,
- LAPACKE_cungql_work,
- LAPACKE_cungqr,
- LAPACKE_cungqr_work,
- LAPACKE_cungrq,
- LAPACKE_cungrq_work,
- LAPACKE_cungtr,
- LAPACKE_cungtr_work,
- LAPACKE_cunmbr,
- LAPACKE_cunmbr_work,
- LAPACKE_cunmhr,
- LAPACKE_cunmhr_work,
- LAPACKE_cunmlq,
- LAPACKE_cunmlq_work,
- LAPACKE_cunmql,
- LAPACKE_cunmql_work,
- LAPACKE_cunmqr,
- LAPACKE_cunmqr_work,
- LAPACKE_cunmrq,
- LAPACKE_cunmrq_work,
- LAPACKE_cunmrz,
- LAPACKE_cunmrz_work,
- LAPACKE_cunmtr,
- LAPACKE_cunmtr_work,
- LAPACKE_cupgtr,
- LAPACKE_cupgtr_work,
- LAPACKE_cupmtr,
- LAPACKE_cupmtr_work,
- LAPACKE_dbbcsd,
- LAPACKE_dbbcsd_work,
- LAPACKE_dbdsdc,
- LAPACKE_dbdsdc_work,
- LAPACKE_dbdsqr,
- LAPACKE_dbdsqr_work,
- LAPACKE_ddisna,
- LAPACKE_ddisna_work,
- LAPACKE_dgbbrd,
- LAPACKE_dgbbrd_work,
- LAPACKE_dgbcon,
- LAPACKE_dgbcon_work,
- LAPACKE_dgbequ,
- LAPACKE_dgbequ_work,
- LAPACKE_dgbequb,
- LAPACKE_dgbequb_work,
- LAPACKE_dgbrfs,
- LAPACKE_dgbrfs_work,
- LAPACKE_dgbsv,
- LAPACKE_dgbsv_work,
- LAPACKE_dgbsvx,
- LAPACKE_dgbsvx_work,
- LAPACKE_dgbtrf,
- LAPACKE_dgbtrf_work,
- LAPACKE_dgbtrs,
- LAPACKE_dgbtrs_work,
- LAPACKE_dgebak,
- LAPACKE_dgebak_work,
- LAPACKE_dgebal,
- LAPACKE_dgebal_work,
- LAPACKE_dgebrd,
- LAPACKE_dgebrd_work,
- LAPACKE_dgecon,
- LAPACKE_dgecon_work,
- LAPACKE_dgeequ,
- LAPACKE_dgeequ_work,
- LAPACKE_dgeequb,
- LAPACKE_dgeequb_work,
- LAPACKE_dgees,
- LAPACKE_dgees_work,
- LAPACKE_dgeesx,
- LAPACKE_dgeesx_work,
- LAPACKE_dgeev,
- LAPACKE_dgeev_work,
- LAPACKE_dgeevx,
- LAPACKE_dgeevx_work,
- LAPACKE_dgehrd,
- LAPACKE_dgehrd_work,
- LAPACKE_dgejsv,
- LAPACKE_dgejsv_work,
- LAPACKE_dgelq2,
- LAPACKE_dgelq2_work,
- LAPACKE_dgelqf,
- LAPACKE_dgelqf_work,
- LAPACKE_dgels,
- LAPACKE_dgels_work,
- LAPACKE_dgelsd,
- LAPACKE_dgelsd_work,
- LAPACKE_dgelss,
- LAPACKE_dgelss_work,
- LAPACKE_dgelsy,
- LAPACKE_dgelsy_work,
- LAPACKE_dgemqrt,
- LAPACKE_dgemqrt_work,
- LAPACKE_dgeqlf,
- LAPACKE_dgeqlf_work,
- LAPACKE_dgeqp3,
- LAPACKE_dgeqp3_work,
- LAPACKE_dgeqpf,
- LAPACKE_dgeqpf_work,
- LAPACKE_dgeqr2,
- LAPACKE_dgeqr2_work,
- LAPACKE_dgeqrf,
- LAPACKE_dgeqrf_work,
- LAPACKE_dgeqrfp,
- LAPACKE_dgeqrfp_work,
- LAPACKE_dgeqrt,
- LAPACKE_dgeqrt2,
- LAPACKE_dgeqrt2_work,
- LAPACKE_dgeqrt3,
- LAPACKE_dgeqrt3_work,
- LAPACKE_dgeqrt_work,
- LAPACKE_dgerfs,
- LAPACKE_dgerfs_work,
- LAPACKE_dgerqf,
- LAPACKE_dgerqf_work,
- LAPACKE_dgesdd,
- LAPACKE_dgesdd_work,
- LAPACKE_dgesv,
- LAPACKE_dgesv_work,
- LAPACKE_dgesvd,
- LAPACKE_dgesvd_work,
- LAPACKE_dgesvj,
- LAPACKE_dgesvj_work,
- LAPACKE_dgesvx,
- LAPACKE_dgesvx_work,
- LAPACKE_dgetf2,
- LAPACKE_dgetf2_work,
- LAPACKE_dgetrf,
- LAPACKE_dgetrf_work,
- LAPACKE_dgetri,
- LAPACKE_dgetri_work,
- LAPACKE_dgetrs,
- LAPACKE_dgetrs_work,
- LAPACKE_dggbak,
- LAPACKE_dggbak_work,
- LAPACKE_dggbal,
- LAPACKE_dggbal_work,
- LAPACKE_dgges,
- LAPACKE_dgges_work,
- LAPACKE_dggesx,
- LAPACKE_dggesx_work,
- LAPACKE_dggev,
- LAPACKE_dggev_work,
- LAPACKE_dggevx,
- LAPACKE_dggevx_work,
- LAPACKE_dggglm,
- LAPACKE_dggglm_work,
- LAPACKE_dgghrd,
- LAPACKE_dgghrd_work,
- LAPACKE_dgglse,
- LAPACKE_dgglse_work,
- LAPACKE_dggqrf,
- LAPACKE_dggqrf_work,
- LAPACKE_dggrqf,
- LAPACKE_dggrqf_work,
- LAPACKE_dggsvd,
- LAPACKE_dggsvd_work,
- LAPACKE_dggsvp,
- LAPACKE_dggsvp_work,
- LAPACKE_dgtcon,
- LAPACKE_dgtcon_work,
- LAPACKE_dgtrfs,
- LAPACKE_dgtrfs_work,
- LAPACKE_dgtsv,
- LAPACKE_dgtsv_work,
- LAPACKE_dgtsvx,
- LAPACKE_dgtsvx_work,
- LAPACKE_dgttrf,
- LAPACKE_dgttrf_work,
- LAPACKE_dgttrs,
- LAPACKE_dgttrs_work,
- LAPACKE_dhgeqz,
- LAPACKE_dhgeqz_work,
- LAPACKE_dhsein,
- LAPACKE_dhsein_work,
- LAPACKE_dhseqr,
- LAPACKE_dhseqr_work,
- LAPACKE_dlacpy,
- LAPACKE_dlacpy_work,
- LAPACKE_dlag2s,
- LAPACKE_dlag2s_work,
- LAPACKE_dlamch,
- LAPACKE_dlamch_work,
- LAPACKE_dlange,
- LAPACKE_dlange_work,
- LAPACKE_dlansy,
- LAPACKE_dlansy_work,
- LAPACKE_dlantr,
- LAPACKE_dlantr_work,
- LAPACKE_dlapmr,
- LAPACKE_dlapmr_work,
- LAPACKE_dlapy2,
- LAPACKE_dlapy2_work,
- LAPACKE_dlapy3,
- LAPACKE_dlapy3_work,
- LAPACKE_dlarfb,
- LAPACKE_dlarfb_work,
- LAPACKE_dlarfg,
- LAPACKE_dlarfg_work,
- LAPACKE_dlarft,
- LAPACKE_dlarft_work,
- LAPACKE_dlarfx,
- LAPACKE_dlarfx_work,
- LAPACKE_dlarnv,
- LAPACKE_dlarnv_work,
- LAPACKE_dlartgp,
- LAPACKE_dlartgp_work,
- LAPACKE_dlartgs,
- LAPACKE_dlartgs_work,
- LAPACKE_dlaset,
- LAPACKE_dlaset_work,
- LAPACKE_dlasrt,
- LAPACKE_dlasrt_work,
- LAPACKE_dlaswp,
- LAPACKE_dlaswp_work,
- LAPACKE_dlauum,
- LAPACKE_dlauum_work,
- LAPACKE_dopgtr,
- LAPACKE_dopgtr_work,
- LAPACKE_dopmtr,
- LAPACKE_dopmtr_work,
- LAPACKE_dorbdb,
- LAPACKE_dorbdb_work,
- LAPACKE_dorcsd,
- LAPACKE_dorcsd_work,
- LAPACKE_dorgbr,
- LAPACKE_dorgbr_work,
- LAPACKE_dorghr,
- LAPACKE_dorghr_work,
- LAPACKE_dorglq,
- LAPACKE_dorglq_work,
- LAPACKE_dorgql,
- LAPACKE_dorgql_work,
- LAPACKE_dorgqr,
- LAPACKE_dorgqr_work,
- LAPACKE_dorgrq,
- LAPACKE_dorgrq_work,
- LAPACKE_dorgtr,
- LAPACKE_dorgtr_work,
- LAPACKE_dormbr,
- LAPACKE_dormbr_work,
- LAPACKE_dormhr,
- LAPACKE_dormhr_work,
- LAPACKE_dormlq,
- LAPACKE_dormlq_work,
- LAPACKE_dormql,
- LAPACKE_dormql_work,
- LAPACKE_dormqr,
- LAPACKE_dormqr_work,
- LAPACKE_dormrq,
- LAPACKE_dormrq_work,
- LAPACKE_dormrz,
- LAPACKE_dormrz_work,
- LAPACKE_dormtr,
- LAPACKE_dormtr_work,
- LAPACKE_dpbcon,
- LAPACKE_dpbcon_work,
- LAPACKE_dpbequ,
- LAPACKE_dpbequ_work,
- LAPACKE_dpbrfs,
- LAPACKE_dpbrfs_work,
- LAPACKE_dpbstf,
- LAPACKE_dpbstf_work,
- LAPACKE_dpbsv,
- LAPACKE_dpbsv_work,
- LAPACKE_dpbsvx,
- LAPACKE_dpbsvx_work,
- LAPACKE_dpbtrf,
- LAPACKE_dpbtrf_work,
- LAPACKE_dpbtrs,
- LAPACKE_dpbtrs_work,
- LAPACKE_dpftrf,
- LAPACKE_dpftrf_work,
- LAPACKE_dpftri,
- LAPACKE_dpftri_work,
- LAPACKE_dpftrs,
- LAPACKE_dpftrs_work,
- LAPACKE_dpocon,
- LAPACKE_dpocon_work,
- LAPACKE_dpoequ,
- LAPACKE_dpoequ_work,
- LAPACKE_dpoequb,
- LAPACKE_dpoequb_work,
- LAPACKE_dporfs,
- LAPACKE_dporfs_work,
- LAPACKE_dposv,
- LAPACKE_dposv_work,
- LAPACKE_dposvx,
- LAPACKE_dposvx_work,
- LAPACKE_dpotrf,
- LAPACKE_dpotrf_work,
- LAPACKE_dpotri,
- LAPACKE_dpotri_work,
- LAPACKE_dpotrs,
- LAPACKE_dpotrs_work,
- LAPACKE_dppcon,
- LAPACKE_dppcon_work,
- LAPACKE_dppequ,
- LAPACKE_dppequ_work,
- LAPACKE_dpprfs,
- LAPACKE_dpprfs_work,
- LAPACKE_dppsv,
- LAPACKE_dppsv_work,
- LAPACKE_dppsvx,
- LAPACKE_dppsvx_work,
- LAPACKE_dpptrf,
- LAPACKE_dpptrf_work,
- LAPACKE_dpptri,
- LAPACKE_dpptri_work,
- LAPACKE_dpptrs,
- LAPACKE_dpptrs_work,
- LAPACKE_dpstrf,
- LAPACKE_dpstrf_work,
- LAPACKE_dptcon,
- LAPACKE_dptcon_work,
- LAPACKE_dpteqr,
- LAPACKE_dpteqr_work,
- LAPACKE_dptrfs,
- LAPACKE_dptrfs_work,
- LAPACKE_dptsv,
- LAPACKE_dptsv_work,
- LAPACKE_dptsvx,
- LAPACKE_dptsvx_work,
- LAPACKE_dpttrf,
- LAPACKE_dpttrf_work,
- LAPACKE_dpttrs,
- LAPACKE_dpttrs_work,
- LAPACKE_dsbev,
- LAPACKE_dsbev_work,
- LAPACKE_dsbevd,
- LAPACKE_dsbevd_work,
- LAPACKE_dsbevx,
- LAPACKE_dsbevx_work,
- LAPACKE_dsbgst,
- LAPACKE_dsbgst_work,
- LAPACKE_dsbgv,
- LAPACKE_dsbgv_work,
- LAPACKE_dsbgvd,
- LAPACKE_dsbgvd_work,
- LAPACKE_dsbgvx,
- LAPACKE_dsbgvx_work,
- LAPACKE_dsbtrd,
- LAPACKE_dsbtrd_work,
- LAPACKE_dsfrk,
- LAPACKE_dsfrk_work,
- LAPACKE_dsgesv,
- LAPACKE_dsgesv_work,
- LAPACKE_dspcon,
- LAPACKE_dspcon_work,
- LAPACKE_dspev,
- LAPACKE_dspev_work,
- LAPACKE_dspevd,
- LAPACKE_dspevd_work,
- LAPACKE_dspevx,
- LAPACKE_dspevx_work,
- LAPACKE_dspgst,
- LAPACKE_dspgst_work,
- LAPACKE_dspgv,
- LAPACKE_dspgv_work,
- LAPACKE_dspgvd,
- LAPACKE_dspgvd_work,
- LAPACKE_dspgvx,
- LAPACKE_dspgvx_work,
- LAPACKE_dsposv,
- LAPACKE_dsposv_work,
- LAPACKE_dsprfs,
- LAPACKE_dsprfs_work,
- LAPACKE_dspsv,
- LAPACKE_dspsv_work,
- LAPACKE_dspsvx,
- LAPACKE_dspsvx_work,
- LAPACKE_dsptrd,
- LAPACKE_dsptrd_work,
- LAPACKE_dsptrf,
- LAPACKE_dsptrf_work,
- LAPACKE_dsptri,
- LAPACKE_dsptri_work,
- LAPACKE_dsptrs,
- LAPACKE_dsptrs_work,
- LAPACKE_dstebz,
- LAPACKE_dstebz_work,
- LAPACKE_dstedc,
- LAPACKE_dstedc_work,
- LAPACKE_dstegr,
- LAPACKE_dstegr_work,
- LAPACKE_dstein,
- LAPACKE_dstein_work,
- LAPACKE_dstemr,
- LAPACKE_dstemr_work,
- LAPACKE_dsteqr,
- LAPACKE_dsteqr_work,
- LAPACKE_dsterf,
- LAPACKE_dsterf_work,
- LAPACKE_dstev,
- LAPACKE_dstev_work,
- LAPACKE_dstevd,
- LAPACKE_dstevd_work,
- LAPACKE_dstevr,
- LAPACKE_dstevr_work,
- LAPACKE_dstevx,
- LAPACKE_dstevx_work,
- LAPACKE_dsycon,
- LAPACKE_dsycon_work,
- LAPACKE_dsyconv,
- LAPACKE_dsyconv_work,
- LAPACKE_dsyequb,
- LAPACKE_dsyequb_work,
- LAPACKE_dsyev,
- LAPACKE_dsyev_work,
- LAPACKE_dsyevd,
- LAPACKE_dsyevd_work,
- LAPACKE_dsyevr,
- LAPACKE_dsyevr_work,
- LAPACKE_dsyevx,
- LAPACKE_dsyevx_work,
- LAPACKE_dsygst,
- LAPACKE_dsygst_work,
- LAPACKE_dsygv,
- LAPACKE_dsygv_work,
- LAPACKE_dsygvd,
- LAPACKE_dsygvd_work,
- LAPACKE_dsygvx,
- LAPACKE_dsygvx_work,
- LAPACKE_dsyrfs,
- LAPACKE_dsyrfs_work,
- LAPACKE_dsysv,
- LAPACKE_dsysv_work,
- LAPACKE_dsysvx,
- LAPACKE_dsysvx_work,
- LAPACKE_dsyswapr,
- LAPACKE_dsyswapr_work,
- LAPACKE_dsytrd,
- LAPACKE_dsytrd_work,
- LAPACKE_dsytrf,
- LAPACKE_dsytrf_work,
- LAPACKE_dsytri,
- LAPACKE_dsytri2,
- LAPACKE_dsytri2_work,
- LAPACKE_dsytri2x,
- LAPACKE_dsytri2x_work,
- LAPACKE_dsytri_work,
- LAPACKE_dsytrs,
- LAPACKE_dsytrs2,
- LAPACKE_dsytrs2_work,
- LAPACKE_dsytrs_work,
- LAPACKE_dtbcon,
- LAPACKE_dtbcon_work,
- LAPACKE_dtbrfs,
- LAPACKE_dtbrfs_work,
- LAPACKE_dtbtrs,
- LAPACKE_dtbtrs_work,
- LAPACKE_dtfsm,
- LAPACKE_dtfsm_work,
- LAPACKE_dtftri,
- LAPACKE_dtftri_work,
- LAPACKE_dtfttp,
- LAPACKE_dtfttp_work,
- LAPACKE_dtfttr,
- LAPACKE_dtfttr_work,
- LAPACKE_dtgevc,
- LAPACKE_dtgevc_work,
- LAPACKE_dtgexc,
- LAPACKE_dtgexc_work,
- LAPACKE_dtgsen,
- LAPACKE_dtgsen_work,
- LAPACKE_dtgsja,
- LAPACKE_dtgsja_work,
- LAPACKE_dtgsna,
- LAPACKE_dtgsna_work,
- LAPACKE_dtgsyl,
- LAPACKE_dtgsyl_work,
- LAPACKE_dtpcon,
- LAPACKE_dtpcon_work,
- LAPACKE_dtpmqrt,
- LAPACKE_dtpmqrt_work,
- LAPACKE_dtpqrt,
- LAPACKE_dtpqrt2,
- LAPACKE_dtpqrt2_work,
- LAPACKE_dtpqrt_work,
- LAPACKE_dtprfb,
- LAPACKE_dtprfb_work,
- LAPACKE_dtprfs,
- LAPACKE_dtprfs_work,
- LAPACKE_dtptri,
- LAPACKE_dtptri_work,
- LAPACKE_dtptrs,
- LAPACKE_dtptrs_work,
- LAPACKE_dtpttf,
- LAPACKE_dtpttf_work,
- LAPACKE_dtpttr,
- LAPACKE_dtpttr_work,
- LAPACKE_dtrcon,
- LAPACKE_dtrcon_work,
- LAPACKE_dtrevc,
- LAPACKE_dtrevc_work,
- LAPACKE_dtrexc,
- LAPACKE_dtrexc_work,
- LAPACKE_dtrrfs,
- LAPACKE_dtrrfs_work,
- LAPACKE_dtrsen,
- LAPACKE_dtrsen_work,
- LAPACKE_dtrsna,
- LAPACKE_dtrsna_work,
- LAPACKE_dtrsyl,
- LAPACKE_dtrsyl_work,
- LAPACKE_dtrtri,
- LAPACKE_dtrtri_work,
- LAPACKE_dtrtrs,
- LAPACKE_dtrtrs_work,
- LAPACKE_dtrttf,
- LAPACKE_dtrttf_work,
- LAPACKE_dtrttp,
- LAPACKE_dtrttp_work,
- LAPACKE_dtzrzf,
- LAPACKE_dtzrzf_work,
- LAPACKE_sbbcsd,
- LAPACKE_sbbcsd_work,
- LAPACKE_sbdsdc,
- LAPACKE_sbdsdc_work,
- LAPACKE_sbdsqr,
- LAPACKE_sbdsqr_work,
- LAPACKE_sdisna,
- LAPACKE_sdisna_work,
- LAPACKE_sgbbrd,
- LAPACKE_sgbbrd_work,
- LAPACKE_sgbcon,
- LAPACKE_sgbcon_work,
- LAPACKE_sgbequ,
- LAPACKE_sgbequ_work,
- LAPACKE_sgbequb,
- LAPACKE_sgbequb_work,
- LAPACKE_sgbrfs,
- LAPACKE_sgbrfs_work,
- LAPACKE_sgbsv,
- LAPACKE_sgbsv_work,
- LAPACKE_sgbsvx,
- LAPACKE_sgbsvx_work,
- LAPACKE_sgbtrf,
- LAPACKE_sgbtrf_work,
- LAPACKE_sgbtrs,
- LAPACKE_sgbtrs_work,
- LAPACKE_sgebak,
- LAPACKE_sgebak_work,
- LAPACKE_sgebal,
- LAPACKE_sgebal_work,
- LAPACKE_sgebrd,
- LAPACKE_sgebrd_work,
- LAPACKE_sgecon,
- LAPACKE_sgecon_work,
- LAPACKE_sgeequ,
- LAPACKE_sgeequ_work,
- LAPACKE_sgeequb,
- LAPACKE_sgeequb_work,
- LAPACKE_sgees,
- LAPACKE_sgees_work,
- LAPACKE_sgeesx,
- LAPACKE_sgeesx_work,
- LAPACKE_sgeev,
- LAPACKE_sgeev_work,
- LAPACKE_sgeevx,
- LAPACKE_sgeevx_work,
- LAPACKE_sgehrd,
- LAPACKE_sgehrd_work,
- LAPACKE_sgejsv,
- LAPACKE_sgejsv_work,
- LAPACKE_sgelq2,
- LAPACKE_sgelq2_work,
- LAPACKE_sgelqf,
- LAPACKE_sgelqf_work,
- LAPACKE_sgels,
- LAPACKE_sgels_work,
- LAPACKE_sgelsd,
- LAPACKE_sgelsd_work,
- LAPACKE_sgelss,
- LAPACKE_sgelss_work,
- LAPACKE_sgelsy,
- LAPACKE_sgelsy_work,
- LAPACKE_sgemqrt,
- LAPACKE_sgemqrt_work,
- LAPACKE_sgeqlf,
- LAPACKE_sgeqlf_work,
- LAPACKE_sgeqp3,
- LAPACKE_sgeqp3_work,
- LAPACKE_sgeqpf,
- LAPACKE_sgeqpf_work,
- LAPACKE_sgeqr2,
- LAPACKE_sgeqr2_work,
- LAPACKE_sgeqrf,
- LAPACKE_sgeqrf_work,
- LAPACKE_sgeqrfp,
- LAPACKE_sgeqrfp_work,
- LAPACKE_sgeqrt,
- LAPACKE_sgeqrt2,
- LAPACKE_sgeqrt2_work,
- LAPACKE_sgeqrt3,
- LAPACKE_sgeqrt3_work,
- LAPACKE_sgeqrt_work,
- LAPACKE_sgerfs,
- LAPACKE_sgerfs_work,
- LAPACKE_sgerqf,
- LAPACKE_sgerqf_work,
- LAPACKE_sgesdd,
- LAPACKE_sgesdd_work,
- LAPACKE_sgesv,
- LAPACKE_sgesv_work,
- LAPACKE_sgesvd,
- LAPACKE_sgesvd_work,
- LAPACKE_sgesvj,
- LAPACKE_sgesvj_work,
- LAPACKE_sgesvx,
- LAPACKE_sgesvx_work,
- LAPACKE_sgetf2,
- LAPACKE_sgetf2_work,
- LAPACKE_sgetrf,
- LAPACKE_sgetrf_work,
- LAPACKE_sgetri,
- LAPACKE_sgetri_work,
- LAPACKE_sgetrs,
- LAPACKE_sgetrs_work,
- LAPACKE_sggbak,
- LAPACKE_sggbak_work,
- LAPACKE_sggbal,
- LAPACKE_sggbal_work,
- LAPACKE_sgges,
- LAPACKE_sgges_work,
- LAPACKE_sggesx,
- LAPACKE_sggesx_work,
- LAPACKE_sggev,
- LAPACKE_sggev_work,
- LAPACKE_sggevx,
- LAPACKE_sggevx_work,
- LAPACKE_sggglm,
- LAPACKE_sggglm_work,
- LAPACKE_sgghrd,
- LAPACKE_sgghrd_work,
- LAPACKE_sgglse,
- LAPACKE_sgglse_work,
- LAPACKE_sggqrf,
- LAPACKE_sggqrf_work,
- LAPACKE_sggrqf,
- LAPACKE_sggrqf_work,
- LAPACKE_sggsvd,
- LAPACKE_sggsvd_work,
- LAPACKE_sggsvp,
- LAPACKE_sggsvp_work,
- LAPACKE_sgtcon,
- LAPACKE_sgtcon_work,
- LAPACKE_sgtrfs,
- LAPACKE_sgtrfs_work,
- LAPACKE_sgtsv,
- LAPACKE_sgtsv_work,
- LAPACKE_sgtsvx,
- LAPACKE_sgtsvx_work,
- LAPACKE_sgttrf,
- LAPACKE_sgttrf_work,
- LAPACKE_sgttrs,
- LAPACKE_sgttrs_work,
- LAPACKE_shgeqz,
- LAPACKE_shgeqz_work,
- LAPACKE_shsein,
- LAPACKE_shsein_work,
- LAPACKE_shseqr,
- LAPACKE_shseqr_work,
- LAPACKE_slacpy,
- LAPACKE_slacpy_work,
- LAPACKE_slag2d,
- LAPACKE_slag2d_work,
- LAPACKE_slamch,
- LAPACKE_slamch_work,
- LAPACKE_slange,
- LAPACKE_slange_work,
- LAPACKE_slansy,
- LAPACKE_slansy_work,
- LAPACKE_slantr,
- LAPACKE_slantr_work,
- LAPACKE_slapmr,
- LAPACKE_slapmr_work,
- LAPACKE_slapy2,
- LAPACKE_slapy2_work,
- LAPACKE_slapy3,
- LAPACKE_slapy3_work,
- LAPACKE_slarfb,
- LAPACKE_slarfb_work,
- LAPACKE_slarfg,
- LAPACKE_slarfg_work,
- LAPACKE_slarft,
- LAPACKE_slarft_work,
- LAPACKE_slarfx,
- LAPACKE_slarfx_work,
- LAPACKE_slarnv,
- LAPACKE_slarnv_work,
- LAPACKE_slartgp,
- LAPACKE_slartgp_work,
- LAPACKE_slartgs,
- LAPACKE_slartgs_work,
- LAPACKE_slaset,
- LAPACKE_slaset_work,
- LAPACKE_slasrt,
- LAPACKE_slasrt_work,
- LAPACKE_slaswp,
- LAPACKE_slaswp_work,
- LAPACKE_slauum,
- LAPACKE_slauum_work,
- LAPACKE_sopgtr,
- LAPACKE_sopgtr_work,
- LAPACKE_sopmtr,
- LAPACKE_sopmtr_work,
- LAPACKE_sorbdb,
- LAPACKE_sorbdb_work,
- LAPACKE_sorcsd,
- LAPACKE_sorcsd_work,
- LAPACKE_sorgbr,
- LAPACKE_sorgbr_work,
- LAPACKE_sorghr,
- LAPACKE_sorghr_work,
- LAPACKE_sorglq,
- LAPACKE_sorglq_work,
- LAPACKE_sorgql,
- LAPACKE_sorgql_work,
- LAPACKE_sorgqr,
- LAPACKE_sorgqr_work,
- LAPACKE_sorgrq,
- LAPACKE_sorgrq_work,
- LAPACKE_sorgtr,
- LAPACKE_sorgtr_work,
- LAPACKE_sormbr,
- LAPACKE_sormbr_work,
- LAPACKE_sormhr,
- LAPACKE_sormhr_work,
- LAPACKE_sormlq,
- LAPACKE_sormlq_work,
- LAPACKE_sormql,
- LAPACKE_sormql_work,
- LAPACKE_sormqr,
- LAPACKE_sormqr_work,
- LAPACKE_sormrq,
- LAPACKE_sormrq_work,
- LAPACKE_sormrz,
- LAPACKE_sormrz_work,
- LAPACKE_sormtr,
- LAPACKE_sormtr_work,
- LAPACKE_spbcon,
- LAPACKE_spbcon_work,
- LAPACKE_spbequ,
- LAPACKE_spbequ_work,
- LAPACKE_spbrfs,
- LAPACKE_spbrfs_work,
- LAPACKE_spbstf,
- LAPACKE_spbstf_work,
- LAPACKE_spbsv,
- LAPACKE_spbsv_work,
- LAPACKE_spbsvx,
- LAPACKE_spbsvx_work,
- LAPACKE_spbtrf,
- LAPACKE_spbtrf_work,
- LAPACKE_spbtrs,
- LAPACKE_spbtrs_work,
- LAPACKE_spftrf,
- LAPACKE_spftrf_work,
- LAPACKE_spftri,
- LAPACKE_spftri_work,
- LAPACKE_spftrs,
- LAPACKE_spftrs_work,
- LAPACKE_spocon,
- LAPACKE_spocon_work,
- LAPACKE_spoequ,
- LAPACKE_spoequ_work,
- LAPACKE_spoequb,
- LAPACKE_spoequb_work,
- LAPACKE_sporfs,
- LAPACKE_sporfs_work,
- LAPACKE_sposv,
- LAPACKE_sposv_work,
- LAPACKE_sposvx,
- LAPACKE_sposvx_work,
- LAPACKE_spotrf,
- LAPACKE_spotrf_work,
- LAPACKE_spotri,
- LAPACKE_spotri_work,
- LAPACKE_spotrs,
- LAPACKE_spotrs_work,
- LAPACKE_sppcon,
- LAPACKE_sppcon_work,
- LAPACKE_sppequ,
- LAPACKE_sppequ_work,
- LAPACKE_spprfs,
- LAPACKE_spprfs_work,
- LAPACKE_sppsv,
- LAPACKE_sppsv_work,
- LAPACKE_sppsvx,
- LAPACKE_sppsvx_work,
- LAPACKE_spptrf,
- LAPACKE_spptrf_work,
- LAPACKE_spptri,
- LAPACKE_spptri_work,
- LAPACKE_spptrs,
- LAPACKE_spptrs_work,
- LAPACKE_spstrf,
- LAPACKE_spstrf_work,
- LAPACKE_sptcon,
- LAPACKE_sptcon_work,
- LAPACKE_spteqr,
- LAPACKE_spteqr_work,
- LAPACKE_sptrfs,
- LAPACKE_sptrfs_work,
- LAPACKE_sptsv,
- LAPACKE_sptsv_work,
- LAPACKE_sptsvx,
- LAPACKE_sptsvx_work,
- LAPACKE_spttrf,
- LAPACKE_spttrf_work,
- LAPACKE_spttrs,
- LAPACKE_spttrs_work,
- LAPACKE_ssbev,
- LAPACKE_ssbev_work,
- LAPACKE_ssbevd,
- LAPACKE_ssbevd_work,
- LAPACKE_ssbevx,
- LAPACKE_ssbevx_work,
- LAPACKE_ssbgst,
- LAPACKE_ssbgst_work,
- LAPACKE_ssbgv,
- LAPACKE_ssbgv_work,
- LAPACKE_ssbgvd,
- LAPACKE_ssbgvd_work,
- LAPACKE_ssbgvx,
- LAPACKE_ssbgvx_work,
- LAPACKE_ssbtrd,
- LAPACKE_ssbtrd_work,
- LAPACKE_ssfrk,
- LAPACKE_ssfrk_work,
- LAPACKE_sspcon,
- LAPACKE_sspcon_work,
- LAPACKE_sspev,
- LAPACKE_sspev_work,
- LAPACKE_sspevd,
- LAPACKE_sspevd_work,
- LAPACKE_sspevx,
- LAPACKE_sspevx_work,
- LAPACKE_sspgst,
- LAPACKE_sspgst_work,
- LAPACKE_sspgv,
- LAPACKE_sspgv_work,
- LAPACKE_sspgvd,
- LAPACKE_sspgvd_work,
- LAPACKE_sspgvx,
- LAPACKE_sspgvx_work,
- LAPACKE_ssprfs,
- LAPACKE_ssprfs_work,
- LAPACKE_sspsv,
- LAPACKE_sspsv_work,
- LAPACKE_sspsvx,
- LAPACKE_sspsvx_work,
- LAPACKE_ssptrd,
- LAPACKE_ssptrd_work,
- LAPACKE_ssptrf,
- LAPACKE_ssptrf_work,
- LAPACKE_ssptri,
- LAPACKE_ssptri_work,
- LAPACKE_ssptrs,
- LAPACKE_ssptrs_work,
- LAPACKE_sstebz,
- LAPACKE_sstebz_work,
- LAPACKE_sstedc,
- LAPACKE_sstedc_work,
- LAPACKE_sstegr,
- LAPACKE_sstegr_work,
- LAPACKE_sstein,
- LAPACKE_sstein_work,
- LAPACKE_sstemr,
- LAPACKE_sstemr_work,
- LAPACKE_ssteqr,
- LAPACKE_ssteqr_work,
- LAPACKE_ssterf,
- LAPACKE_ssterf_work,
- LAPACKE_sstev,
- LAPACKE_sstev_work,
- LAPACKE_sstevd,
- LAPACKE_sstevd_work,
- LAPACKE_sstevr,
- LAPACKE_sstevr_work,
- LAPACKE_sstevx,
- LAPACKE_sstevx_work,
- LAPACKE_ssycon,
- LAPACKE_ssycon_work,
- LAPACKE_ssyconv,
- LAPACKE_ssyconv_work,
- LAPACKE_ssyequb,
- LAPACKE_ssyequb_work,
- LAPACKE_ssyev,
- LAPACKE_ssyev_work,
- LAPACKE_ssyevd,
- LAPACKE_ssyevd_work,
- LAPACKE_ssyevr,
- LAPACKE_ssyevr_work,
- LAPACKE_ssyevx,
- LAPACKE_ssyevx_work,
- LAPACKE_ssygst,
- LAPACKE_ssygst_work,
- LAPACKE_ssygv,
- LAPACKE_ssygv_work,
- LAPACKE_ssygvd,
- LAPACKE_ssygvd_work,
- LAPACKE_ssygvx,
- LAPACKE_ssygvx_work,
- LAPACKE_ssyrfs,
- LAPACKE_ssyrfs_work,
- LAPACKE_ssysv,
- LAPACKE_ssysv_work,
- LAPACKE_ssysvx,
- LAPACKE_ssysvx_work,
- LAPACKE_ssyswapr,
- LAPACKE_ssyswapr_work,
- LAPACKE_ssytrd,
- LAPACKE_ssytrd_work,
- LAPACKE_ssytrf,
- LAPACKE_ssytrf_work,
- LAPACKE_ssytri,
- LAPACKE_ssytri2,
- LAPACKE_ssytri2_work,
- LAPACKE_ssytri2x,
- LAPACKE_ssytri2x_work,
- LAPACKE_ssytri_work,
- LAPACKE_ssytrs,
- LAPACKE_ssytrs2,
- LAPACKE_ssytrs2_work,
- LAPACKE_ssytrs_work,
- LAPACKE_stbcon,
- LAPACKE_stbcon_work,
- LAPACKE_stbrfs,
- LAPACKE_stbrfs_work,
- LAPACKE_stbtrs,
- LAPACKE_stbtrs_work,
- LAPACKE_stfsm,
- LAPACKE_stfsm_work,
- LAPACKE_stftri,
- LAPACKE_stftri_work,
- LAPACKE_stfttp,
- LAPACKE_stfttp_work,
- LAPACKE_stfttr,
- LAPACKE_stfttr_work,
- LAPACKE_stgevc,
- LAPACKE_stgevc_work,
- LAPACKE_stgexc,
- LAPACKE_stgexc_work,
- LAPACKE_stgsen,
- LAPACKE_stgsen_work,
- LAPACKE_stgsja,
- LAPACKE_stgsja_work,
- LAPACKE_stgsna,
- LAPACKE_stgsna_work,
- LAPACKE_stgsyl,
- LAPACKE_stgsyl_work,
- LAPACKE_stpcon,
- LAPACKE_stpcon_work,
- LAPACKE_stpmqrt,
- LAPACKE_stpmqrt_work,
- LAPACKE_stpqrt2,
- LAPACKE_stpqrt2_work,
- LAPACKE_stprfb,
- LAPACKE_stprfb_work,
- LAPACKE_stprfs,
- LAPACKE_stprfs_work,
- LAPACKE_stptri,
- LAPACKE_stptri_work,
- LAPACKE_stptrs,
- LAPACKE_stptrs_work,
- LAPACKE_stpttf,
- LAPACKE_stpttf_work,
- LAPACKE_stpttr,
- LAPACKE_stpttr_work,
- LAPACKE_strcon,
- LAPACKE_strcon_work,
- LAPACKE_strevc,
- LAPACKE_strevc_work,
- LAPACKE_strexc,
- LAPACKE_strexc_work,
- LAPACKE_strrfs,
- LAPACKE_strrfs_work,
- LAPACKE_strsen,
- LAPACKE_strsen_work,
- LAPACKE_strsna,
- LAPACKE_strsna_work,
- LAPACKE_strsyl,
- LAPACKE_strsyl_work,
- LAPACKE_strtri,
- LAPACKE_strtri_work,
- LAPACKE_strtrs,
- LAPACKE_strtrs_work,
- LAPACKE_strttf,
- LAPACKE_strttf_work,
- LAPACKE_strttp,
- LAPACKE_strttp_work,
- LAPACKE_stzrzf,
- LAPACKE_stzrzf_work,
- LAPACKE_zbbcsd,
- LAPACKE_zbbcsd_work,
- LAPACKE_zbdsqr,
- LAPACKE_zbdsqr_work,
- LAPACKE_zcgesv,
- LAPACKE_zcgesv_work,
- LAPACKE_zcposv,
- LAPACKE_zcposv_work,
- LAPACKE_zgbbrd,
- LAPACKE_zgbbrd_work,
- LAPACKE_zgbcon,
- LAPACKE_zgbcon_work,
- LAPACKE_zgbequ,
- LAPACKE_zgbequ_work,
- LAPACKE_zgbequb,
- LAPACKE_zgbequb_work,
- LAPACKE_zgbrfs,
- LAPACKE_zgbrfs_work,
- LAPACKE_zgbsv,
- LAPACKE_zgbsv_work,
- LAPACKE_zgbsvx,
- LAPACKE_zgbsvx_work,
- LAPACKE_zgbtrf,
- LAPACKE_zgbtrf_work,
- LAPACKE_zgbtrs,
- LAPACKE_zgbtrs_work,
- LAPACKE_zgebak,
- LAPACKE_zgebak_work,
- LAPACKE_zgebal,
- LAPACKE_zgebal_work,
- LAPACKE_zgebrd,
- LAPACKE_zgebrd_work,
- LAPACKE_zgecon,
- LAPACKE_zgecon_work,
- LAPACKE_zgeequ,
- LAPACKE_zgeequ_work,
- LAPACKE_zgeequb,
- LAPACKE_zgeequb_work,
- LAPACKE_zgees,
- LAPACKE_zgees_work,
- LAPACKE_zgeesx,
- LAPACKE_zgeesx_work,
- LAPACKE_zgeev,
- LAPACKE_zgeev_work,
- LAPACKE_zgeevx,
- LAPACKE_zgeevx_work,
- LAPACKE_zgehrd,
- LAPACKE_zgehrd_work,
- LAPACKE_zgelq2,
- LAPACKE_zgelq2_work,
- LAPACKE_zgelqf,
- LAPACKE_zgelqf_work,
- LAPACKE_zgels,
- LAPACKE_zgels_work,
- LAPACKE_zgelsd,
- LAPACKE_zgelsd_work,
- LAPACKE_zgelss,
- LAPACKE_zgelss_work,
- LAPACKE_zgelsy,
- LAPACKE_zgelsy_work,
- LAPACKE_zgemqrt,
- LAPACKE_zgemqrt_work,
- LAPACKE_zgeqlf,
- LAPACKE_zgeqlf_work,
- LAPACKE_zgeqp3,
- LAPACKE_zgeqp3_work,
- LAPACKE_zgeqpf,
- LAPACKE_zgeqpf_work,
- LAPACKE_zgeqr2,
- LAPACKE_zgeqr2_work,
- LAPACKE_zgeqrf,
- LAPACKE_zgeqrf_work,
- LAPACKE_zgeqrfp,
- LAPACKE_zgeqrfp_work,
- LAPACKE_zgeqrt,
- LAPACKE_zgeqrt2,
- LAPACKE_zgeqrt2_work,
- LAPACKE_zgeqrt3,
- LAPACKE_zgeqrt3_work,
- LAPACKE_zgeqrt_work,
- LAPACKE_zgerfs,
- LAPACKE_zgerfs_work,
- LAPACKE_zgerqf,
- LAPACKE_zgerqf_work,
- LAPACKE_zgesdd,
- LAPACKE_zgesdd_work,
- LAPACKE_zgesv,
- LAPACKE_zgesv_work,
- LAPACKE_zgesvd,
- LAPACKE_zgesvd_work,
- LAPACKE_zgesvx,
- LAPACKE_zgesvx_work,
- LAPACKE_zgetf2,
- LAPACKE_zgetf2_work,
- LAPACKE_zgetrf,
- LAPACKE_zgetrf_work,
- LAPACKE_zgetri,
- LAPACKE_zgetri_work,
- LAPACKE_zgetrs,
- LAPACKE_zgetrs_work,
- LAPACKE_zggbak,
- LAPACKE_zggbak_work,
- LAPACKE_zggbal,
- LAPACKE_zggbal_work,
- LAPACKE_zgges,
- LAPACKE_zgges_work,
- LAPACKE_zggesx,
- LAPACKE_zggesx_work,
- LAPACKE_zggev,
- LAPACKE_zggev_work,
- LAPACKE_zggevx,
- LAPACKE_zggevx_work,
- LAPACKE_zggglm,
- LAPACKE_zggglm_work,
- LAPACKE_zgghrd,
- LAPACKE_zgghrd_work,
- LAPACKE_zgglse,
- LAPACKE_zgglse_work,
- LAPACKE_zggqrf,
- LAPACKE_zggqrf_work,
- LAPACKE_zggrqf,
- LAPACKE_zggrqf_work,
- LAPACKE_zggsvd,
- LAPACKE_zggsvd_work,
- LAPACKE_zggsvp,
- LAPACKE_zggsvp_work,
- LAPACKE_zgtcon,
- LAPACKE_zgtcon_work,
- LAPACKE_zgtrfs,
- LAPACKE_zgtrfs_work,
- LAPACKE_zgtsv,
- LAPACKE_zgtsv_work,
- LAPACKE_zgtsvx,
- LAPACKE_zgtsvx_work,
- LAPACKE_zgttrf,
- LAPACKE_zgttrf_work,
- LAPACKE_zgttrs,
- LAPACKE_zgttrs_work,
- LAPACKE_zhbev,
- LAPACKE_zhbev_work,
- LAPACKE_zhbevd,
- LAPACKE_zhbevd_work,
- LAPACKE_zhbevx,
- LAPACKE_zhbevx_work,
- LAPACKE_zhbgst,
- LAPACKE_zhbgst_work,
- LAPACKE_zhbgv,
- LAPACKE_zhbgv_work,
- LAPACKE_zhbgvd,
- LAPACKE_zhbgvd_work,
- LAPACKE_zhbgvx,
- LAPACKE_zhbgvx_work,
- LAPACKE_zhbtrd,
- LAPACKE_zhbtrd_work,
- LAPACKE_zhecon,
- LAPACKE_zhecon_work,
- LAPACKE_zheequb,
- LAPACKE_zheequb_work,
- LAPACKE_zheev,
- LAPACKE_zheev_work,
- LAPACKE_zheevd,
- LAPACKE_zheevd_work,
- LAPACKE_zheevr,
- LAPACKE_zheevr_work,
- LAPACKE_zheevx,
- LAPACKE_zheevx_work,
- LAPACKE_zhegst,
- LAPACKE_zhegst_work,
- LAPACKE_zhegv,
- LAPACKE_zhegv_work,
- LAPACKE_zhegvd,
- LAPACKE_zhegvd_work,
- LAPACKE_zhegvx,
- LAPACKE_zhegvx_work,
- LAPACKE_zherfs,
- LAPACKE_zherfs_work,
- LAPACKE_zhesv,
- LAPACKE_zhesv_work,
- LAPACKE_zhesvx,
- LAPACKE_zhesvx_work,
- LAPACKE_zheswapr,
- LAPACKE_zheswapr_work,
- LAPACKE_zhetrd,
- LAPACKE_zhetrd_work,
- LAPACKE_zhetrf,
- LAPACKE_zhetrf_work,
- LAPACKE_zhetri,
- LAPACKE_zhetri2,
- LAPACKE_zhetri2_work,
- LAPACKE_zhetri2x,
- LAPACKE_zhetri2x_work,
- LAPACKE_zhetri_work,
- LAPACKE_zhetrs,
- LAPACKE_zhetrs2,
- LAPACKE_zhetrs2_work,
- LAPACKE_zhetrs_work,
- LAPACKE_zhfrk,
- LAPACKE_zhfrk_work,
- LAPACKE_zhgeqz,
- LAPACKE_zhgeqz_work,
- LAPACKE_zhpcon,
- LAPACKE_zhpcon_work,
- LAPACKE_zhpev,
- LAPACKE_zhpev_work,
- LAPACKE_zhpevd,
- LAPACKE_zhpevd_work,
- LAPACKE_zhpevx,
- LAPACKE_zhpevx_work,
- LAPACKE_zhpgst,
- LAPACKE_zhpgst_work,
- LAPACKE_zhpgv,
- LAPACKE_zhpgv_work,
- LAPACKE_zhpgvd,
- LAPACKE_zhpgvd_work,
- LAPACKE_zhpgvx,
- LAPACKE_zhpgvx_work,
- LAPACKE_zhprfs,
- LAPACKE_zhprfs_work,
- LAPACKE_zhpsv,
- LAPACKE_zhpsv_work,
- LAPACKE_zhpsvx,
- LAPACKE_zhpsvx_work,
- LAPACKE_zhptrd,
- LAPACKE_zhptrd_work,
- LAPACKE_zhptrf,
- LAPACKE_zhptrf_work,
- LAPACKE_zhptri,
- LAPACKE_zhptri_work,
- LAPACKE_zhptrs,
- LAPACKE_zhptrs_work,
- LAPACKE_zhsein,
- LAPACKE_zhsein_work,
- LAPACKE_zhseqr,
- LAPACKE_zhseqr_work,
- LAPACKE_zlacgv,
- LAPACKE_zlacgv_work,
- LAPACKE_zlacpy,
- LAPACKE_zlacpy_work,
- LAPACKE_zlag2c,
- LAPACKE_zlag2c_work,
- LAPACKE_zlange,
- LAPACKE_zlange_work,
- LAPACKE_zlanhe,
- LAPACKE_zlanhe_work,
- LAPACKE_zlansy,
- LAPACKE_zlansy_work,
- LAPACKE_zlantr,
- LAPACKE_zlantr_work,
- LAPACKE_zlapmr,
- LAPACKE_zlapmr_work,
- LAPACKE_zlarfb,
- LAPACKE_zlarfb_work,
- LAPACKE_zlarfg,
- LAPACKE_zlarfg_work,
- LAPACKE_zlarft,
- LAPACKE_zlarft_work,
- LAPACKE_zlarfx,
- LAPACKE_zlarfx_work,
- LAPACKE_zlarnv,
- LAPACKE_zlarnv_work,
- LAPACKE_zlaset,
- LAPACKE_zlaset_work,
- LAPACKE_zlaswp,
- LAPACKE_zlaswp_work,
- LAPACKE_zlauum,
- LAPACKE_zlauum_work,
- LAPACKE_zpbcon,
- LAPACKE_zpbcon_work,
- LAPACKE_zpbequ,
- LAPACKE_zpbequ_work,
- LAPACKE_zpbrfs,
- LAPACKE_zpbrfs_work,
- LAPACKE_zpbstf,
- LAPACKE_zpbstf_work,
- LAPACKE_zpbsv,
- LAPACKE_zpbsv_work,
- LAPACKE_zpbsvx,
- LAPACKE_zpbsvx_work,
- LAPACKE_zpbtrf,
- LAPACKE_zpbtrf_work,
- LAPACKE_zpbtrs,
- LAPACKE_zpbtrs_work,
- LAPACKE_zpftrf,
- LAPACKE_zpftrf_work,
- LAPACKE_zpftri,
- LAPACKE_zpftri_work,
- LAPACKE_zpftrs,
- LAPACKE_zpftrs_work,
- LAPACKE_zpocon,
- LAPACKE_zpocon_work,
- LAPACKE_zpoequ,
- LAPACKE_zpoequ_work,
- LAPACKE_zpoequb,
- LAPACKE_zpoequb_work,
- LAPACKE_zporfs,
- LAPACKE_zporfs_work,
- LAPACKE_zposv,
- LAPACKE_zposv_work,
- LAPACKE_zposvx,
- LAPACKE_zposvx_work,
- LAPACKE_zpotrf,
- LAPACKE_zpotrf_work,
- LAPACKE_zpotri,
- LAPACKE_zpotri_work,
- LAPACKE_zpotrs,
- LAPACKE_zpotrs_work,
- LAPACKE_zppcon,
- LAPACKE_zppcon_work,
- LAPACKE_zppequ,
- LAPACKE_zppequ_work,
- LAPACKE_zpprfs,
- LAPACKE_zpprfs_work,
- LAPACKE_zppsv,
- LAPACKE_zppsv_work,
- LAPACKE_zppsvx,
- LAPACKE_zppsvx_work,
- LAPACKE_zpptrf,
- LAPACKE_zpptrf_work,
- LAPACKE_zpptri,
- LAPACKE_zpptri_work,
- LAPACKE_zpptrs,
- LAPACKE_zpptrs_work,
- LAPACKE_zpstrf,
- LAPACKE_zpstrf_work,
- LAPACKE_zptcon,
- LAPACKE_zptcon_work,
- LAPACKE_zpteqr,
- LAPACKE_zpteqr_work,
- LAPACKE_zptrfs,
- LAPACKE_zptrfs_work,
- LAPACKE_zptsv,
- LAPACKE_zptsv_work,
- LAPACKE_zptsvx,
- LAPACKE_zptsvx_work,
- LAPACKE_zpttrf,
- LAPACKE_zpttrf_work,
- LAPACKE_zpttrs,
- LAPACKE_zpttrs_work,
- LAPACKE_zspcon,
- LAPACKE_zspcon_work,
- LAPACKE_zsprfs,
- LAPACKE_zsprfs_work,
- LAPACKE_zspsv,
- LAPACKE_zspsv_work,
- LAPACKE_zspsvx,
- LAPACKE_zspsvx_work,
- LAPACKE_zsptrf,
- LAPACKE_zsptrf_work,
- LAPACKE_zsptri,
- LAPACKE_zsptri_work,
- LAPACKE_zsptrs,
- LAPACKE_zsptrs_work,
- LAPACKE_zstedc,
- LAPACKE_zstedc_work,
- LAPACKE_zstegr,
- LAPACKE_zstegr_work,
- LAPACKE_zstein,
- LAPACKE_zstein_work,
- LAPACKE_zstemr,
- LAPACKE_zstemr_work,
- LAPACKE_zsteqr,
- LAPACKE_zsteqr_work,
- LAPACKE_zsycon,
- LAPACKE_zsycon_work,
- LAPACKE_zsyconv,
- LAPACKE_zsyconv_work,
- LAPACKE_zsyequb,
- LAPACKE_zsyequb_work,
- LAPACKE_zsyrfs,
- LAPACKE_zsyrfs_work,
- LAPACKE_zsysv,
- LAPACKE_zsysv_work,
- LAPACKE_zsysvx,
- LAPACKE_zsysvx_work,
- LAPACKE_zsyswapr,
- LAPACKE_zsyswapr_work,
- LAPACKE_zsytrf,
- LAPACKE_zsytrf_work,
- LAPACKE_zsytri,
- LAPACKE_zsytri2,
- LAPACKE_zsytri2_work,
- LAPACKE_zsytri2x,
- LAPACKE_zsytri2x_work,
- LAPACKE_zsytri_work,
- LAPACKE_zsytrs,
- LAPACKE_zsytrs2,
- LAPACKE_zsytrs2_work,
- LAPACKE_zsytrs_work,
- LAPACKE_ztbcon,
- LAPACKE_ztbcon_work,
- LAPACKE_ztbrfs,
- LAPACKE_ztbrfs_work,
- LAPACKE_ztbtrs,
- LAPACKE_ztbtrs_work,
- LAPACKE_ztfsm,
- LAPACKE_ztfsm_work,
- LAPACKE_ztftri,
- LAPACKE_ztftri_work,
- LAPACKE_ztfttp,
- LAPACKE_ztfttp_work,
- LAPACKE_ztfttr,
- LAPACKE_ztfttr_work,
- LAPACKE_ztgevc,
- LAPACKE_ztgevc_work,
- LAPACKE_ztgexc,
- LAPACKE_ztgexc_work,
- LAPACKE_ztgsen,
- LAPACKE_ztgsen_work,
- LAPACKE_ztgsja,
- LAPACKE_ztgsja_work,
- LAPACKE_ztgsna,
- LAPACKE_ztgsna_work,
- LAPACKE_ztgsyl,
- LAPACKE_ztgsyl_work,
- LAPACKE_ztpcon,
- LAPACKE_ztpcon_work,
- LAPACKE_ztpmqrt,
- LAPACKE_ztpmqrt_work,
- LAPACKE_ztpqrt,
- LAPACKE_ztpqrt2,
- LAPACKE_ztpqrt2_work,
- LAPACKE_ztpqrt_work,
- LAPACKE_ztprfb,
- LAPACKE_ztprfb_work,
- LAPACKE_ztprfs,
- LAPACKE_ztprfs_work,
- LAPACKE_ztptri,
- LAPACKE_ztptri_work,
- LAPACKE_ztptrs,
- LAPACKE_ztptrs_work,
- LAPACKE_ztpttf,
- LAPACKE_ztpttf_work,
- LAPACKE_ztpttr,
- LAPACKE_ztpttr_work,
- LAPACKE_ztrcon,
- LAPACKE_ztrcon_work,
- LAPACKE_ztrevc,
- LAPACKE_ztrevc_work,
- LAPACKE_ztrexc,
- LAPACKE_ztrexc_work,
- LAPACKE_ztrrfs,
- LAPACKE_ztrrfs_work,
- LAPACKE_ztrsen,
- LAPACKE_ztrsen_work,
- LAPACKE_ztrsna,
- LAPACKE_ztrsna_work,
- LAPACKE_ztrsyl,
- LAPACKE_ztrsyl_work,
- LAPACKE_ztrtri,
- LAPACKE_ztrtri_work,
- LAPACKE_ztrtrs,
- LAPACKE_ztrtrs_work,
- LAPACKE_ztrttf,
- LAPACKE_ztrttf_work,
- LAPACKE_ztrttp,
- LAPACKE_ztrttp_work,
- LAPACKE_ztzrzf,
- LAPACKE_ztzrzf_work,
- LAPACKE_zunbdb,
- LAPACKE_zunbdb_work,
- LAPACKE_zuncsd,
- LAPACKE_zuncsd_work,
- LAPACKE_zungbr,
- LAPACKE_zungbr_work,
- LAPACKE_zunghr,
- LAPACKE_zunghr_work,
- LAPACKE_zunglq,
- LAPACKE_zunglq_work,
- LAPACKE_zungql,
- LAPACKE_zungql_work,
- LAPACKE_zungqr,
- LAPACKE_zungqr_work,
- LAPACKE_zungrq,
- LAPACKE_zungrq_work,
- LAPACKE_zungtr,
- LAPACKE_zungtr_work,
- LAPACKE_zunmbr,
- LAPACKE_zunmbr_work,
- LAPACKE_zunmhr,
- LAPACKE_zunmhr_work,
- LAPACKE_zunmlq,
- LAPACKE_zunmlq_work,
- LAPACKE_zunmql,
- LAPACKE_zunmql_work,
- LAPACKE_zunmqr,
- LAPACKE_zunmqr_work,
- LAPACKE_zunmrq,
- LAPACKE_zunmrq_work,
- LAPACKE_zunmrz,
- LAPACKE_zunmrz_work,
- LAPACKE_zunmtr,
- LAPACKE_zunmtr_work,
- LAPACKE_zupgtr,
- LAPACKE_zupgtr_work,
- LAPACKE_zupmtr,
- LAPACKE_zupmtr_work,
- LAPACKE_zsyr,
- LAPACKE_csyr,
- LAPACKE_zsyr_work,
- LAPACKE_csyr_work,
+ # @(SRC_OBJ) from `lapack-3.5.0/lapacke/src/Makefile`
+ LAPACKE_cbbcsd,
+ LAPACKE_cbbcsd_work,
+ LAPACKE_cbdsqr,
+ LAPACKE_cbdsqr_work,
+ LAPACKE_cgbbrd,
+ LAPACKE_cgbbrd_work,
+ LAPACKE_cgbcon,
+ LAPACKE_cgbcon_work,
+ LAPACKE_cgbequ,
+ LAPACKE_cgbequ_work,
+ LAPACKE_cgbequb,
+ LAPACKE_cgbequb_work,
+ LAPACKE_cgbrfs,
+ LAPACKE_cgbrfs_work,
+ LAPACKE_cgbsv,
+ LAPACKE_cgbsv_work,
+ LAPACKE_cgbsvx,
+ LAPACKE_cgbsvx_work,
+ LAPACKE_cgbtrf,
+ LAPACKE_cgbtrf_work,
+ LAPACKE_cgbtrs,
+ LAPACKE_cgbtrs_work,
+ LAPACKE_cgebak,
+ LAPACKE_cgebak_work,
+ LAPACKE_cgebal,
+ LAPACKE_cgebal_work,
+ LAPACKE_cgebrd,
+ LAPACKE_cgebrd_work,
+ LAPACKE_cgecon,
+ LAPACKE_cgecon_work,
+ LAPACKE_cgeequ,
+ LAPACKE_cgeequ_work,
+ LAPACKE_cgeequb,
+ LAPACKE_cgeequb_work,
+ LAPACKE_cgees,
+ LAPACKE_cgees_work,
+ LAPACKE_cgeesx,
+ LAPACKE_cgeesx_work,
+ LAPACKE_cgeev,
+ LAPACKE_cgeev_work,
+ LAPACKE_cgeevx,
+ LAPACKE_cgeevx_work,
+ LAPACKE_cgehrd,
+ LAPACKE_cgehrd_work,
+ LAPACKE_cgelq2,
+ LAPACKE_cgelq2_work,
+ LAPACKE_cgelqf,
+ LAPACKE_cgelqf_work,
+ LAPACKE_cgels,
+ LAPACKE_cgels_work,
+ LAPACKE_cgelsd,
+ LAPACKE_cgelsd_work,
+ LAPACKE_cgelss,
+ LAPACKE_cgelss_work,
+ LAPACKE_cgelsy,
+ LAPACKE_cgelsy_work,
+ LAPACKE_cgemqrt,
+ LAPACKE_cgemqrt_work,
+ LAPACKE_cgeqlf,
+ LAPACKE_cgeqlf_work,
+ LAPACKE_cgeqp3,
+ LAPACKE_cgeqp3_work,
+ LAPACKE_cgeqpf,
+ LAPACKE_cgeqpf_work,
+ LAPACKE_cgeqr2,
+ LAPACKE_cgeqr2_work,
+ LAPACKE_cgeqrf,
+ LAPACKE_cgeqrf_work,
+ LAPACKE_cgeqrfp,
+ LAPACKE_cgeqrfp_work,
+ LAPACKE_cgeqrt,
+ LAPACKE_cgeqrt2,
+ LAPACKE_cgeqrt2_work,
+ LAPACKE_cgeqrt3,
+ LAPACKE_cgeqrt3_work,
+ LAPACKE_cgeqrt_work,
+ LAPACKE_cgerfs,
+ LAPACKE_cgerfs_work,
+ LAPACKE_cgerqf,
+ LAPACKE_cgerqf_work,
+ LAPACKE_cgesdd,
+ LAPACKE_cgesdd_work,
+ LAPACKE_cgesv,
+ LAPACKE_cgesv_work,
+ LAPACKE_cgesvd,
+ LAPACKE_cgesvd_work,
+ LAPACKE_cgesvx,
+ LAPACKE_cgesvx_work,
+ LAPACKE_cgetf2,
+ LAPACKE_cgetf2_work,
+ LAPACKE_cgetrf,
+ LAPACKE_cgetrf_work,
+ LAPACKE_cgetri,
+ LAPACKE_cgetri_work,
+ LAPACKE_cgetrs,
+ LAPACKE_cgetrs_work,
+ LAPACKE_cggbak,
+ LAPACKE_cggbak_work,
+ LAPACKE_cggbal,
+ LAPACKE_cggbal_work,
+ LAPACKE_cgges,
+ LAPACKE_cgges_work,
+ LAPACKE_cggesx,
+ LAPACKE_cggesx_work,
+ LAPACKE_cggev,
+ LAPACKE_cggev_work,
+ LAPACKE_cggevx,
+ LAPACKE_cggevx_work,
+ LAPACKE_cggglm,
+ LAPACKE_cggglm_work,
+ LAPACKE_cgghrd,
+ LAPACKE_cgghrd_work,
+ LAPACKE_cgglse,
+ LAPACKE_cgglse_work,
+ LAPACKE_cggqrf,
+ LAPACKE_cggqrf_work,
+ LAPACKE_cggrqf,
+ LAPACKE_cggrqf_work,
+ LAPACKE_cggsvd,
+ LAPACKE_cggsvd_work,
+ LAPACKE_cggsvp,
+ LAPACKE_cggsvp_work,
+ LAPACKE_cgtcon,
+ LAPACKE_cgtcon_work,
+ LAPACKE_cgtrfs,
+ LAPACKE_cgtrfs_work,
+ LAPACKE_cgtsv,
+ LAPACKE_cgtsv_work,
+ LAPACKE_cgtsvx,
+ LAPACKE_cgtsvx_work,
+ LAPACKE_cgttrf,
+ LAPACKE_cgttrf_work,
+ LAPACKE_cgttrs,
+ LAPACKE_cgttrs_work,
+ LAPACKE_chbev,
+ LAPACKE_chbev_work,
+ LAPACKE_chbevd,
+ LAPACKE_chbevd_work,
+ LAPACKE_chbevx,
+ LAPACKE_chbevx_work,
+ LAPACKE_chbgst,
+ LAPACKE_chbgst_work,
+ LAPACKE_chbgv,
+ LAPACKE_chbgv_work,
+ LAPACKE_chbgvd,
+ LAPACKE_chbgvd_work,
+ LAPACKE_chbgvx,
+ LAPACKE_chbgvx_work,
+ LAPACKE_chbtrd,
+ LAPACKE_chbtrd_work,
+ LAPACKE_checon,
+ LAPACKE_checon_work,
+ LAPACKE_cheequb,
+ LAPACKE_cheequb_work,
+ LAPACKE_cheev,
+ LAPACKE_cheev_work,
+ LAPACKE_cheevd,
+ LAPACKE_cheevd_work,
+ LAPACKE_cheevr,
+ LAPACKE_cheevr_work,
+ LAPACKE_cheevx,
+ LAPACKE_cheevx_work,
+ LAPACKE_chegst,
+ LAPACKE_chegst_work,
+ LAPACKE_chegv,
+ LAPACKE_chegv_work,
+ LAPACKE_chegvd,
+ LAPACKE_chegvd_work,
+ LAPACKE_chegvx,
+ LAPACKE_chegvx_work,
+ LAPACKE_cherfs,
+ LAPACKE_cherfs_work,
+ LAPACKE_chesv,
+ LAPACKE_chesv_work,
+ LAPACKE_chesvx,
+ LAPACKE_chesvx_work,
+ LAPACKE_cheswapr,
+ LAPACKE_cheswapr_work,
+ LAPACKE_chetrd,
+ LAPACKE_chetrd_work,
+ LAPACKE_chetrf,
+ LAPACKE_chetrf_work,
+ LAPACKE_chetri,
+ LAPACKE_chetri2,
+ LAPACKE_chetri2_work,
+ LAPACKE_chetri2x,
+ LAPACKE_chetri2x_work,
+ LAPACKE_chetri_work,
+ LAPACKE_chetrs,
+ LAPACKE_chetrs2,
+ LAPACKE_chetrs2_work,
+ LAPACKE_chetrs_work,
+ LAPACKE_chfrk,
+ LAPACKE_chfrk_work,
+ LAPACKE_chgeqz,
+ LAPACKE_chgeqz_work,
+ LAPACKE_chpcon,
+ LAPACKE_chpcon_work,
+ LAPACKE_chpev,
+ LAPACKE_chpev_work,
+ LAPACKE_chpevd,
+ LAPACKE_chpevd_work,
+ LAPACKE_chpevx,
+ LAPACKE_chpevx_work,
+ LAPACKE_chpgst,
+ LAPACKE_chpgst_work,
+ LAPACKE_chpgv,
+ LAPACKE_chpgv_work,
+ LAPACKE_chpgvd,
+ LAPACKE_chpgvd_work,
+ LAPACKE_chpgvx,
+ LAPACKE_chpgvx_work,
+ LAPACKE_chprfs,
+ LAPACKE_chprfs_work,
+ LAPACKE_chpsv,
+ LAPACKE_chpsv_work,
+ LAPACKE_chpsvx,
+ LAPACKE_chpsvx_work,
+ LAPACKE_chptrd,
+ LAPACKE_chptrd_work,
+ LAPACKE_chptrf,
+ LAPACKE_chptrf_work,
+ LAPACKE_chptri,
+ LAPACKE_chptri_work,
+ LAPACKE_chptrs,
+ LAPACKE_chptrs_work,
+ LAPACKE_chsein,
+ LAPACKE_chsein_work,
+ LAPACKE_chseqr,
+ LAPACKE_chseqr_work,
+ LAPACKE_clacgv,
+ LAPACKE_clacgv_work,
+ LAPACKE_clacn2,
+ LAPACKE_clacn2_work,
+ LAPACKE_clacp2,
+ LAPACKE_clacp2_work,
+ LAPACKE_clacpy,
+ LAPACKE_clacpy_work,
+ LAPACKE_clag2z,
+ LAPACKE_clag2z_work,
+ LAPACKE_clange,
+ LAPACKE_clange_work,
+ LAPACKE_clanhe,
+ LAPACKE_clanhe_work,
+ LAPACKE_clansy,
+ LAPACKE_clansy_work,
+ LAPACKE_clantr,
+ LAPACKE_clantr_work,
+ LAPACKE_clapmr,
+ LAPACKE_clapmr_work,
+ LAPACKE_clarfb,
+ LAPACKE_clarfb_work,
+ LAPACKE_clarfg,
+ LAPACKE_clarfg_work,
+ LAPACKE_clarft,
+ LAPACKE_clarft_work,
+ LAPACKE_clarfx,
+ LAPACKE_clarfx_work,
+ LAPACKE_clarnv,
+ LAPACKE_clarnv_work,
+ LAPACKE_claset,
+ LAPACKE_claset_work,
+ LAPACKE_claswp,
+ LAPACKE_claswp_work,
+ LAPACKE_clauum,
+ LAPACKE_clauum_work,
+ LAPACKE_cpbcon,
+ LAPACKE_cpbcon_work,
+ LAPACKE_cpbequ,
+ LAPACKE_cpbequ_work,
+ LAPACKE_cpbrfs,
+ LAPACKE_cpbrfs_work,
+ LAPACKE_cpbstf,
+ LAPACKE_cpbstf_work,
+ LAPACKE_cpbsv,
+ LAPACKE_cpbsv_work,
+ LAPACKE_cpbsvx,
+ LAPACKE_cpbsvx_work,
+ LAPACKE_cpbtrf,
+ LAPACKE_cpbtrf_work,
+ LAPACKE_cpbtrs,
+ LAPACKE_cpbtrs_work,
+ LAPACKE_cpftrf,
+ LAPACKE_cpftrf_work,
+ LAPACKE_cpftri,
+ LAPACKE_cpftri_work,
+ LAPACKE_cpftrs,
+ LAPACKE_cpftrs_work,
+ LAPACKE_cpocon,
+ LAPACKE_cpocon_work,
+ LAPACKE_cpoequ,
+ LAPACKE_cpoequ_work,
+ LAPACKE_cpoequb,
+ LAPACKE_cpoequb_work,
+ LAPACKE_cporfs,
+ LAPACKE_cporfs_work,
+ LAPACKE_cposv,
+ LAPACKE_cposv_work,
+ LAPACKE_cposvx,
+ LAPACKE_cposvx_work,
+ LAPACKE_cpotrf,
+ LAPACKE_cpotrf_work,
+ LAPACKE_cpotri,
+ LAPACKE_cpotri_work,
+ LAPACKE_cpotrs,
+ LAPACKE_cpotrs_work,
+ LAPACKE_cppcon,
+ LAPACKE_cppcon_work,
+ LAPACKE_cppequ,
+ LAPACKE_cppequ_work,
+ LAPACKE_cpprfs,
+ LAPACKE_cpprfs_work,
+ LAPACKE_cppsv,
+ LAPACKE_cppsv_work,
+ LAPACKE_cppsvx,
+ LAPACKE_cppsvx_work,
+ LAPACKE_cpptrf,
+ LAPACKE_cpptrf_work,
+ LAPACKE_cpptri,
+ LAPACKE_cpptri_work,
+ LAPACKE_cpptrs,
+ LAPACKE_cpptrs_work,
+ LAPACKE_cpstrf,
+ LAPACKE_cpstrf_work,
+ LAPACKE_cptcon,
+ LAPACKE_cptcon_work,
+ LAPACKE_cpteqr,
+ LAPACKE_cpteqr_work,
+ LAPACKE_cptrfs,
+ LAPACKE_cptrfs_work,
+ LAPACKE_cptsv,
+ LAPACKE_cptsv_work,
+ LAPACKE_cptsvx,
+ LAPACKE_cptsvx_work,
+ LAPACKE_cpttrf,
+ LAPACKE_cpttrf_work,
+ LAPACKE_cpttrs,
+ LAPACKE_cpttrs_work,
+ LAPACKE_cspcon,
+ LAPACKE_cspcon_work,
+ LAPACKE_csprfs,
+ LAPACKE_csprfs_work,
+ LAPACKE_cspsv,
+ LAPACKE_cspsv_work,
+ LAPACKE_cspsvx,
+ LAPACKE_cspsvx_work,
+ LAPACKE_csptrf,
+ LAPACKE_csptrf_work,
+ LAPACKE_csptri,
+ LAPACKE_csptri_work,
+ LAPACKE_csptrs,
+ LAPACKE_csptrs_work,
+ LAPACKE_cstedc,
+ LAPACKE_cstedc_work,
+ LAPACKE_cstegr,
+ LAPACKE_cstegr_work,
+ LAPACKE_cstein,
+ LAPACKE_cstein_work,
+ LAPACKE_cstemr,
+ LAPACKE_cstemr_work,
+ LAPACKE_csteqr,
+ LAPACKE_csteqr_work,
+ LAPACKE_csycon,
+ LAPACKE_csycon_work,
+ LAPACKE_csyconv,
+ LAPACKE_csyconv_work,
+ LAPACKE_csyequb,
+ LAPACKE_csyequb_work,
+ LAPACKE_csyrfs,
+ LAPACKE_csyrfs_work,
+ LAPACKE_csysv,
+ LAPACKE_csysv_rook,
+ LAPACKE_csysv_rook_work,
+ LAPACKE_csysv_work,
+ LAPACKE_csysvx,
+ LAPACKE_csysvx_work,
+ LAPACKE_csyswapr,
+ LAPACKE_csyswapr_work,
+ LAPACKE_csytrf,
+ LAPACKE_csytrf_work,
+ LAPACKE_csytri,
+ LAPACKE_csytri2,
+ LAPACKE_csytri2_work,
+ LAPACKE_csytri2x,
+ LAPACKE_csytri2x_work,
+ LAPACKE_csytri_work,
+ LAPACKE_csytrs,
+ LAPACKE_csytrs2,
+ LAPACKE_csytrs2_work,
+ LAPACKE_csytrs_work,
+ LAPACKE_ctbcon,
+ LAPACKE_ctbcon_work,
+ LAPACKE_ctbrfs,
+ LAPACKE_ctbrfs_work,
+ LAPACKE_ctbtrs,
+ LAPACKE_ctbtrs_work,
+ LAPACKE_ctfsm,
+ LAPACKE_ctfsm_work,
+ LAPACKE_ctftri,
+ LAPACKE_ctftri_work,
+ LAPACKE_ctfttp,
+ LAPACKE_ctfttp_work,
+ LAPACKE_ctfttr,
+ LAPACKE_ctfttr_work,
+ LAPACKE_ctgevc,
+ LAPACKE_ctgevc_work,
+ LAPACKE_ctgexc,
+ LAPACKE_ctgexc_work,
+ LAPACKE_ctgsen,
+ LAPACKE_ctgsen_work,
+ LAPACKE_ctgsja,
+ LAPACKE_ctgsja_work,
+ LAPACKE_ctgsna,
+ LAPACKE_ctgsna_work,
+ LAPACKE_ctgsyl,
+ LAPACKE_ctgsyl_work,
+ LAPACKE_ctpcon,
+ LAPACKE_ctpcon_work,
+ LAPACKE_ctpmqrt,
+ LAPACKE_ctpmqrt_work,
+ LAPACKE_ctpqrt,
+ LAPACKE_ctpqrt2,
+ LAPACKE_ctpqrt2_work,
+ LAPACKE_ctpqrt_work,
+ LAPACKE_ctprfb,
+ LAPACKE_ctprfb_work,
+ LAPACKE_ctprfs,
+ LAPACKE_ctprfs_work,
+ LAPACKE_ctptri,
+ LAPACKE_ctptri_work,
+ LAPACKE_ctptrs,
+ LAPACKE_ctptrs_work,
+ LAPACKE_ctpttf,
+ LAPACKE_ctpttf_work,
+ LAPACKE_ctpttr,
+ LAPACKE_ctpttr_work,
+ LAPACKE_ctrcon,
+ LAPACKE_ctrcon_work,
+ LAPACKE_ctrevc,
+ LAPACKE_ctrevc_work,
+ LAPACKE_ctrexc,
+ LAPACKE_ctrexc_work,
+ LAPACKE_ctrrfs,
+ LAPACKE_ctrrfs_work,
+ LAPACKE_ctrsen,
+ LAPACKE_ctrsen_work,
+ LAPACKE_ctrsna,
+ LAPACKE_ctrsna_work,
+ LAPACKE_ctrsyl,
+ LAPACKE_ctrsyl_work,
+ LAPACKE_ctrtri,
+ LAPACKE_ctrtri_work,
+ LAPACKE_ctrtrs,
+ LAPACKE_ctrtrs_work,
+ LAPACKE_ctrttf,
+ LAPACKE_ctrttf_work,
+ LAPACKE_ctrttp,
+ LAPACKE_ctrttp_work,
+ LAPACKE_ctzrzf,
+ LAPACKE_ctzrzf_work,
+ LAPACKE_cunbdb,
+ LAPACKE_cunbdb_work,
+ LAPACKE_cuncsd,
+ LAPACKE_cuncsd_work,
+ LAPACKE_cungbr,
+ LAPACKE_cungbr_work,
+ LAPACKE_cunghr,
+ LAPACKE_cunghr_work,
+ LAPACKE_cunglq,
+ LAPACKE_cunglq_work,
+ LAPACKE_cungql,
+ LAPACKE_cungql_work,
+ LAPACKE_cungqr,
+ LAPACKE_cungqr_work,
+ LAPACKE_cungrq,
+ LAPACKE_cungrq_work,
+ LAPACKE_cungtr,
+ LAPACKE_cungtr_work,
+ LAPACKE_cunmbr,
+ LAPACKE_cunmbr_work,
+ LAPACKE_cunmhr,
+ LAPACKE_cunmhr_work,
+ LAPACKE_cunmlq,
+ LAPACKE_cunmlq_work,
+ LAPACKE_cunmql,
+ LAPACKE_cunmql_work,
+ LAPACKE_cunmqr,
+ LAPACKE_cunmqr_work,
+ LAPACKE_cunmrq,
+ LAPACKE_cunmrq_work,
+ LAPACKE_cunmrz,
+ LAPACKE_cunmrz_work,
+ LAPACKE_cunmtr,
+ LAPACKE_cunmtr_work,
+ LAPACKE_cupgtr,
+ LAPACKE_cupgtr_work,
+ LAPACKE_cupmtr,
+ LAPACKE_cupmtr_work,
+ LAPACKE_dbbcsd,
+ LAPACKE_dbbcsd_work,
+ LAPACKE_dbdsdc,
+ LAPACKE_dbdsdc_work,
+ LAPACKE_dbdsqr,
+ LAPACKE_dbdsqr_work,
+ LAPACKE_ddisna,
+ LAPACKE_ddisna_work,
+ LAPACKE_dgbbrd,
+ LAPACKE_dgbbrd_work,
+ LAPACKE_dgbcon,
+ LAPACKE_dgbcon_work,
+ LAPACKE_dgbequ,
+ LAPACKE_dgbequ_work,
+ LAPACKE_dgbequb,
+ LAPACKE_dgbequb_work,
+ LAPACKE_dgbrfs,
+ LAPACKE_dgbrfs_work,
+ LAPACKE_dgbsv,
+ LAPACKE_dgbsv_work,
+ LAPACKE_dgbsvx,
+ LAPACKE_dgbsvx_work,
+ LAPACKE_dgbtrf,
+ LAPACKE_dgbtrf_work,
+ LAPACKE_dgbtrs,
+ LAPACKE_dgbtrs_work,
+ LAPACKE_dgebak,
+ LAPACKE_dgebak_work,
+ LAPACKE_dgebal,
+ LAPACKE_dgebal_work,
+ LAPACKE_dgebrd,
+ LAPACKE_dgebrd_work,
+ LAPACKE_dgecon,
+ LAPACKE_dgecon_work,
+ LAPACKE_dgeequ,
+ LAPACKE_dgeequ_work,
+ LAPACKE_dgeequb,
+ LAPACKE_dgeequb_work,
+ LAPACKE_dgees,
+ LAPACKE_dgees_work,
+ LAPACKE_dgeesx,
+ LAPACKE_dgeesx_work,
+ LAPACKE_dgeev,
+ LAPACKE_dgeev_work,
+ LAPACKE_dgeevx,
+ LAPACKE_dgeevx_work,
+ LAPACKE_dgehrd,
+ LAPACKE_dgehrd_work,
+ LAPACKE_dgejsv,
+ LAPACKE_dgejsv_work,
+ LAPACKE_dgelq2,
+ LAPACKE_dgelq2_work,
+ LAPACKE_dgelqf,
+ LAPACKE_dgelqf_work,
+ LAPACKE_dgels,
+ LAPACKE_dgels_work,
+ LAPACKE_dgelsd,
+ LAPACKE_dgelsd_work,
+ LAPACKE_dgelss,
+ LAPACKE_dgelss_work,
+ LAPACKE_dgelsy,
+ LAPACKE_dgelsy_work,
+ LAPACKE_dgemqrt,
+ LAPACKE_dgemqrt_work,
+ LAPACKE_dgeqlf,
+ LAPACKE_dgeqlf_work,
+ LAPACKE_dgeqp3,
+ LAPACKE_dgeqp3_work,
+ LAPACKE_dgeqpf,
+ LAPACKE_dgeqpf_work,
+ LAPACKE_dgeqr2,
+ LAPACKE_dgeqr2_work,
+ LAPACKE_dgeqrf,
+ LAPACKE_dgeqrf_work,
+ LAPACKE_dgeqrfp,
+ LAPACKE_dgeqrfp_work,
+ LAPACKE_dgeqrt,
+ LAPACKE_dgeqrt2,
+ LAPACKE_dgeqrt2_work,
+ LAPACKE_dgeqrt3,
+ LAPACKE_dgeqrt3_work,
+ LAPACKE_dgeqrt_work,
+ LAPACKE_dgerfs,
+ LAPACKE_dgerfs_work,
+ LAPACKE_dgerqf,
+ LAPACKE_dgerqf_work,
+ LAPACKE_dgesdd,
+ LAPACKE_dgesdd_work,
+ LAPACKE_dgesv,
+ LAPACKE_dgesv_work,
+ LAPACKE_dgesvd,
+ LAPACKE_dgesvd_work,
+ LAPACKE_dgesvj,
+ LAPACKE_dgesvj_work,
+ LAPACKE_dgesvx,
+ LAPACKE_dgesvx_work,
+ LAPACKE_dgetf2,
+ LAPACKE_dgetf2_work,
+ LAPACKE_dgetrf,
+ LAPACKE_dgetrf_work,
+ LAPACKE_dgetri,
+ LAPACKE_dgetri_work,
+ LAPACKE_dgetrs,
+ LAPACKE_dgetrs_work,
+ LAPACKE_dggbak,
+ LAPACKE_dggbak_work,
+ LAPACKE_dggbal,
+ LAPACKE_dggbal_work,
+ LAPACKE_dgges,
+ LAPACKE_dgges_work,
+ LAPACKE_dggesx,
+ LAPACKE_dggesx_work,
+ LAPACKE_dggev,
+ LAPACKE_dggev_work,
+ LAPACKE_dggevx,
+ LAPACKE_dggevx_work,
+ LAPACKE_dggglm,
+ LAPACKE_dggglm_work,
+ LAPACKE_dgghrd,
+ LAPACKE_dgghrd_work,
+ LAPACKE_dgglse,
+ LAPACKE_dgglse_work,
+ LAPACKE_dggqrf,
+ LAPACKE_dggqrf_work,
+ LAPACKE_dggrqf,
+ LAPACKE_dggrqf_work,
+ LAPACKE_dggsvd,
+ LAPACKE_dggsvd_work,
+ LAPACKE_dggsvp,
+ LAPACKE_dggsvp_work,
+ LAPACKE_dgtcon,
+ LAPACKE_dgtcon_work,
+ LAPACKE_dgtrfs,
+ LAPACKE_dgtrfs_work,
+ LAPACKE_dgtsv,
+ LAPACKE_dgtsv_work,
+ LAPACKE_dgtsvx,
+ LAPACKE_dgtsvx_work,
+ LAPACKE_dgttrf,
+ LAPACKE_dgttrf_work,
+ LAPACKE_dgttrs,
+ LAPACKE_dgttrs_work,
+ LAPACKE_dhgeqz,
+ LAPACKE_dhgeqz_work,
+ LAPACKE_dhsein,
+ LAPACKE_dhsein_work,
+ LAPACKE_dhseqr,
+ LAPACKE_dhseqr_work,
+ LAPACKE_dlacn2,
+ LAPACKE_dlacn2_work,
+ LAPACKE_dlacpy,
+ LAPACKE_dlacpy_work,
+ LAPACKE_dlag2s,
+ LAPACKE_dlag2s_work,
+ LAPACKE_dlamch,
+ LAPACKE_dlamch_work,
+ LAPACKE_dlange,
+ LAPACKE_dlange_work,
+ LAPACKE_dlansy,
+ LAPACKE_dlansy_work,
+ LAPACKE_dlantr,
+ LAPACKE_dlantr_work,
+ LAPACKE_dlapmr,
+ LAPACKE_dlapmr_work,
+ LAPACKE_dlapy2,
+ LAPACKE_dlapy2_work,
+ LAPACKE_dlapy3,
+ LAPACKE_dlapy3_work,
+ LAPACKE_dlarfb,
+ LAPACKE_dlarfb_work,
+ LAPACKE_dlarfg,
+ LAPACKE_dlarfg_work,
+ LAPACKE_dlarft,
+ LAPACKE_dlarft_work,
+ LAPACKE_dlarfx,
+ LAPACKE_dlarfx_work,
+ LAPACKE_dlarnv,
+ LAPACKE_dlarnv_work,
+ LAPACKE_dlartgp,
+ LAPACKE_dlartgp_work,
+ LAPACKE_dlartgs,
+ LAPACKE_dlartgs_work,
+ LAPACKE_dlaset,
+ LAPACKE_dlaset_work,
+ LAPACKE_dlasrt,
+ LAPACKE_dlasrt_work,
+ LAPACKE_dlaswp,
+ LAPACKE_dlaswp_work,
+ LAPACKE_dlauum,
+ LAPACKE_dlauum_work,
+ LAPACKE_dopgtr,
+ LAPACKE_dopgtr_work,
+ LAPACKE_dopmtr,
+ LAPACKE_dopmtr_work,
+ LAPACKE_dorbdb,
+ LAPACKE_dorbdb_work,
+ LAPACKE_dorcsd,
+ LAPACKE_dorcsd_work,
+ LAPACKE_dorgbr,
+ LAPACKE_dorgbr_work,
+ LAPACKE_dorghr,
+ LAPACKE_dorghr_work,
+ LAPACKE_dorglq,
+ LAPACKE_dorglq_work,
+ LAPACKE_dorgql,
+ LAPACKE_dorgql_work,
+ LAPACKE_dorgqr,
+ LAPACKE_dorgqr_work,
+ LAPACKE_dorgrq,
+ LAPACKE_dorgrq_work,
+ LAPACKE_dorgtr,
+ LAPACKE_dorgtr_work,
+ LAPACKE_dormbr,
+ LAPACKE_dormbr_work,
+ LAPACKE_dormhr,
+ LAPACKE_dormhr_work,
+ LAPACKE_dormlq,
+ LAPACKE_dormlq_work,
+ LAPACKE_dormql,
+ LAPACKE_dormql_work,
+ LAPACKE_dormqr,
+ LAPACKE_dormqr_work,
+ LAPACKE_dormrq,
+ LAPACKE_dormrq_work,
+ LAPACKE_dormrz,
+ LAPACKE_dormrz_work,
+ LAPACKE_dormtr,
+ LAPACKE_dormtr_work,
+ LAPACKE_dpbcon,
+ LAPACKE_dpbcon_work,
+ LAPACKE_dpbequ,
+ LAPACKE_dpbequ_work,
+ LAPACKE_dpbrfs,
+ LAPACKE_dpbrfs_work,
+ LAPACKE_dpbstf,
+ LAPACKE_dpbstf_work,
+ LAPACKE_dpbsv,
+ LAPACKE_dpbsv_work,
+ LAPACKE_dpbsvx,
+ LAPACKE_dpbsvx_work,
+ LAPACKE_dpbtrf,
+ LAPACKE_dpbtrf_work,
+ LAPACKE_dpbtrs,
+ LAPACKE_dpbtrs_work,
+ LAPACKE_dpftrf,
+ LAPACKE_dpftrf_work,
+ LAPACKE_dpftri,
+ LAPACKE_dpftri_work,
+ LAPACKE_dpftrs,
+ LAPACKE_dpftrs_work,
+ LAPACKE_dpocon,
+ LAPACKE_dpocon_work,
+ LAPACKE_dpoequ,
+ LAPACKE_dpoequ_work,
+ LAPACKE_dpoequb,
+ LAPACKE_dpoequb_work,
+ LAPACKE_dporfs,
+ LAPACKE_dporfs_work,
+ LAPACKE_dposv,
+ LAPACKE_dposv_work,
+ LAPACKE_dposvx,
+ LAPACKE_dposvx_work,
+ LAPACKE_dpotrf,
+ LAPACKE_dpotrf_work,
+ LAPACKE_dpotri,
+ LAPACKE_dpotri_work,
+ LAPACKE_dpotrs,
+ LAPACKE_dpotrs_work,
+ LAPACKE_dppcon,
+ LAPACKE_dppcon_work,
+ LAPACKE_dppequ,
+ LAPACKE_dppequ_work,
+ LAPACKE_dpprfs,
+ LAPACKE_dpprfs_work,
+ LAPACKE_dppsv,
+ LAPACKE_dppsv_work,
+ LAPACKE_dppsvx,
+ LAPACKE_dppsvx_work,
+ LAPACKE_dpptrf,
+ LAPACKE_dpptrf_work,
+ LAPACKE_dpptri,
+ LAPACKE_dpptri_work,
+ LAPACKE_dpptrs,
+ LAPACKE_dpptrs_work,
+ LAPACKE_dpstrf,
+ LAPACKE_dpstrf_work,
+ LAPACKE_dptcon,
+ LAPACKE_dptcon_work,
+ LAPACKE_dpteqr,
+ LAPACKE_dpteqr_work,
+ LAPACKE_dptrfs,
+ LAPACKE_dptrfs_work,
+ LAPACKE_dptsv,
+ LAPACKE_dptsv_work,
+ LAPACKE_dptsvx,
+ LAPACKE_dptsvx_work,
+ LAPACKE_dpttrf,
+ LAPACKE_dpttrf_work,
+ LAPACKE_dpttrs,
+ LAPACKE_dpttrs_work,
+ LAPACKE_dsbev,
+ LAPACKE_dsbev_work,
+ LAPACKE_dsbevd,
+ LAPACKE_dsbevd_work,
+ LAPACKE_dsbevx,
+ LAPACKE_dsbevx_work,
+ LAPACKE_dsbgst,
+ LAPACKE_dsbgst_work,
+ LAPACKE_dsbgv,
+ LAPACKE_dsbgv_work,
+ LAPACKE_dsbgvd,
+ LAPACKE_dsbgvd_work,
+ LAPACKE_dsbgvx,
+ LAPACKE_dsbgvx_work,
+ LAPACKE_dsbtrd,
+ LAPACKE_dsbtrd_work,
+ LAPACKE_dsfrk,
+ LAPACKE_dsfrk_work,
+ LAPACKE_dsgesv,
+ LAPACKE_dsgesv_work,
+ LAPACKE_dspcon,
+ LAPACKE_dspcon_work,
+ LAPACKE_dspev,
+ LAPACKE_dspev_work,
+ LAPACKE_dspevd,
+ LAPACKE_dspevd_work,
+ LAPACKE_dspevx,
+ LAPACKE_dspevx_work,
+ LAPACKE_dspgst,
+ LAPACKE_dspgst_work,
+ LAPACKE_dspgv,
+ LAPACKE_dspgv_work,
+ LAPACKE_dspgvd,
+ LAPACKE_dspgvd_work,
+ LAPACKE_dspgvx,
+ LAPACKE_dspgvx_work,
+ LAPACKE_dsposv,
+ LAPACKE_dsposv_work,
+ LAPACKE_dsprfs,
+ LAPACKE_dsprfs_work,
+ LAPACKE_dspsv,
+ LAPACKE_dspsv_work,
+ LAPACKE_dspsvx,
+ LAPACKE_dspsvx_work,
+ LAPACKE_dsptrd,
+ LAPACKE_dsptrd_work,
+ LAPACKE_dsptrf,
+ LAPACKE_dsptrf_work,
+ LAPACKE_dsptri,
+ LAPACKE_dsptri_work,
+ LAPACKE_dsptrs,
+ LAPACKE_dsptrs_work,
+ LAPACKE_dstebz,
+ LAPACKE_dstebz_work,
+ LAPACKE_dstedc,
+ LAPACKE_dstedc_work,
+ LAPACKE_dstegr,
+ LAPACKE_dstegr_work,
+ LAPACKE_dstein,
+ LAPACKE_dstein_work,
+ LAPACKE_dstemr,
+ LAPACKE_dstemr_work,
+ LAPACKE_dsteqr,
+ LAPACKE_dsteqr_work,
+ LAPACKE_dsterf,
+ LAPACKE_dsterf_work,
+ LAPACKE_dstev,
+ LAPACKE_dstev_work,
+ LAPACKE_dstevd,
+ LAPACKE_dstevd_work,
+ LAPACKE_dstevr,
+ LAPACKE_dstevr_work,
+ LAPACKE_dstevx,
+ LAPACKE_dstevx_work,
+ LAPACKE_dsycon,
+ LAPACKE_dsycon_work,
+ LAPACKE_dsyconv,
+ LAPACKE_dsyconv_work,
+ LAPACKE_dsyequb,
+ LAPACKE_dsyequb_work,
+ LAPACKE_dsyev,
+ LAPACKE_dsyev_work,
+ LAPACKE_dsyevd,
+ LAPACKE_dsyevd_work,
+ LAPACKE_dsyevr,
+ LAPACKE_dsyevr_work,
+ LAPACKE_dsyevx,
+ LAPACKE_dsyevx_work,
+ LAPACKE_dsygst,
+ LAPACKE_dsygst_work,
+ LAPACKE_dsygv,
+ LAPACKE_dsygv_work,
+ LAPACKE_dsygvd,
+ LAPACKE_dsygvd_work,
+ LAPACKE_dsygvx,
+ LAPACKE_dsygvx_work,
+ LAPACKE_dsyrfs,
+ LAPACKE_dsyrfs_work,
+ LAPACKE_dsysv,
+ LAPACKE_dsysv_rook,
+ LAPACKE_dsysv_rook_work,
+ LAPACKE_dsysv_work,
+ LAPACKE_dsysvx,
+ LAPACKE_dsysvx_work,
+ LAPACKE_dsyswapr,
+ LAPACKE_dsyswapr_work,
+ LAPACKE_dsytrd,
+ LAPACKE_dsytrd_work,
+ LAPACKE_dsytrf,
+ LAPACKE_dsytrf_work,
+ LAPACKE_dsytri,
+ LAPACKE_dsytri2,
+ LAPACKE_dsytri2_work,
+ LAPACKE_dsytri2x,
+ LAPACKE_dsytri2x_work,
+ LAPACKE_dsytri_work,
+ LAPACKE_dsytrs,
+ LAPACKE_dsytrs2,
+ LAPACKE_dsytrs2_work,
+ LAPACKE_dsytrs_work,
+ LAPACKE_dtbcon,
+ LAPACKE_dtbcon_work,
+ LAPACKE_dtbrfs,
+ LAPACKE_dtbrfs_work,
+ LAPACKE_dtbtrs,
+ LAPACKE_dtbtrs_work,
+ LAPACKE_dtfsm,
+ LAPACKE_dtfsm_work,
+ LAPACKE_dtftri,
+ LAPACKE_dtftri_work,
+ LAPACKE_dtfttp,
+ LAPACKE_dtfttp_work,
+ LAPACKE_dtfttr,
+ LAPACKE_dtfttr_work,
+ LAPACKE_dtgevc,
+ LAPACKE_dtgevc_work,
+ LAPACKE_dtgexc,
+ LAPACKE_dtgexc_work,
+ LAPACKE_dtgsen,
+ LAPACKE_dtgsen_work,
+ LAPACKE_dtgsja,
+ LAPACKE_dtgsja_work,
+ LAPACKE_dtgsna,
+ LAPACKE_dtgsna_work,
+ LAPACKE_dtgsyl,
+ LAPACKE_dtgsyl_work,
+ LAPACKE_dtpcon,
+ LAPACKE_dtpcon_work,
+ LAPACKE_dtpmqrt,
+ LAPACKE_dtpmqrt_work,
+ LAPACKE_dtpqrt,
+ LAPACKE_dtpqrt2,
+ LAPACKE_dtpqrt2_work,
+ LAPACKE_dtpqrt_work,
+ LAPACKE_dtprfb,
+ LAPACKE_dtprfb_work,
+ LAPACKE_dtprfs,
+ LAPACKE_dtprfs_work,
+ LAPACKE_dtptri,
+ LAPACKE_dtptri_work,
+ LAPACKE_dtptrs,
+ LAPACKE_dtptrs_work,
+ LAPACKE_dtpttf,
+ LAPACKE_dtpttf_work,
+ LAPACKE_dtpttr,
+ LAPACKE_dtpttr_work,
+ LAPACKE_dtrcon,
+ LAPACKE_dtrcon_work,
+ LAPACKE_dtrevc,
+ LAPACKE_dtrevc_work,
+ LAPACKE_dtrexc,
+ LAPACKE_dtrexc_work,
+ LAPACKE_dtrrfs,
+ LAPACKE_dtrrfs_work,
+ LAPACKE_dtrsen,
+ LAPACKE_dtrsen_work,
+ LAPACKE_dtrsna,
+ LAPACKE_dtrsna_work,
+ LAPACKE_dtrsyl,
+ LAPACKE_dtrsyl_work,
+ LAPACKE_dtrtri,
+ LAPACKE_dtrtri_work,
+ LAPACKE_dtrtrs,
+ LAPACKE_dtrtrs_work,
+ LAPACKE_dtrttf,
+ LAPACKE_dtrttf_work,
+ LAPACKE_dtrttp,
+ LAPACKE_dtrttp_work,
+ LAPACKE_dtzrzf,
+ LAPACKE_dtzrzf_work,
+ LAPACKE_sbbcsd,
+ LAPACKE_sbbcsd_work,
+ LAPACKE_sbdsdc,
+ LAPACKE_sbdsdc_work,
+ LAPACKE_sbdsqr,
+ LAPACKE_sbdsqr_work,
+ LAPACKE_sdisna,
+ LAPACKE_sdisna_work,
+ LAPACKE_sgbbrd,
+ LAPACKE_sgbbrd_work,
+ LAPACKE_sgbcon,
+ LAPACKE_sgbcon_work,
+ LAPACKE_sgbequ,
+ LAPACKE_sgbequ_work,
+ LAPACKE_sgbequb,
+ LAPACKE_sgbequb_work,
+ LAPACKE_sgbrfs,
+ LAPACKE_sgbrfs_work,
+ LAPACKE_sgbsv,
+ LAPACKE_sgbsv_work,
+ LAPACKE_sgbsvx,
+ LAPACKE_sgbsvx_work,
+ LAPACKE_sgbtrf,
+ LAPACKE_sgbtrf_work,
+ LAPACKE_sgbtrs,
+ LAPACKE_sgbtrs_work,
+ LAPACKE_sgebak,
+ LAPACKE_sgebak_work,
+ LAPACKE_sgebal,
+ LAPACKE_sgebal_work,
+ LAPACKE_sgebrd,
+ LAPACKE_sgebrd_work,
+ LAPACKE_sgecon,
+ LAPACKE_sgecon_work,
+ LAPACKE_sgeequ,
+ LAPACKE_sgeequ_work,
+ LAPACKE_sgeequb,
+ LAPACKE_sgeequb_work,
+ LAPACKE_sgees,
+ LAPACKE_sgees_work,
+ LAPACKE_sgeesx,
+ LAPACKE_sgeesx_work,
+ LAPACKE_sgeev,
+ LAPACKE_sgeev_work,
+ LAPACKE_sgeevx,
+ LAPACKE_sgeevx_work,
+ LAPACKE_sgehrd,
+ LAPACKE_sgehrd_work,
+ LAPACKE_sgejsv,
+ LAPACKE_sgejsv_work,
+ LAPACKE_sgelq2,
+ LAPACKE_sgelq2_work,
+ LAPACKE_sgelqf,
+ LAPACKE_sgelqf_work,
+ LAPACKE_sgels,
+ LAPACKE_sgels_work,
+ LAPACKE_sgelsd,
+ LAPACKE_sgelsd_work,
+ LAPACKE_sgelss,
+ LAPACKE_sgelss_work,
+ LAPACKE_sgelsy,
+ LAPACKE_sgelsy_work,
+ LAPACKE_sgemqrt,
+ LAPACKE_sgemqrt_work,
+ LAPACKE_sgeqlf,
+ LAPACKE_sgeqlf_work,
+ LAPACKE_sgeqp3,
+ LAPACKE_sgeqp3_work,
+ LAPACKE_sgeqpf,
+ LAPACKE_sgeqpf_work,
+ LAPACKE_sgeqr2,
+ LAPACKE_sgeqr2_work,
+ LAPACKE_sgeqrf,
+ LAPACKE_sgeqrf_work,
+ LAPACKE_sgeqrfp,
+ LAPACKE_sgeqrfp_work,
+ LAPACKE_sgeqrt,
+ LAPACKE_sgeqrt2,
+ LAPACKE_sgeqrt2_work,
+ LAPACKE_sgeqrt3,
+ LAPACKE_sgeqrt3_work,
+ LAPACKE_sgeqrt_work,
+ LAPACKE_sgerfs,
+ LAPACKE_sgerfs_work,
+ LAPACKE_sgerqf,
+ LAPACKE_sgerqf_work,
+ LAPACKE_sgesdd,
+ LAPACKE_sgesdd_work,
+ LAPACKE_sgesv,
+ LAPACKE_sgesv_work,
+ LAPACKE_sgesvd,
+ LAPACKE_sgesvd_work,
+ LAPACKE_sgesvj,
+ LAPACKE_sgesvj_work,
+ LAPACKE_sgesvx,
+ LAPACKE_sgesvx_work,
+ LAPACKE_sgetf2,
+ LAPACKE_sgetf2_work,
+ LAPACKE_sgetrf,
+ LAPACKE_sgetrf_work,
+ LAPACKE_sgetri,
+ LAPACKE_sgetri_work,
+ LAPACKE_sgetrs,
+ LAPACKE_sgetrs_work,
+ LAPACKE_sggbak,
+ LAPACKE_sggbak_work,
+ LAPACKE_sggbal,
+ LAPACKE_sggbal_work,
+ LAPACKE_sgges,
+ LAPACKE_sgges_work,
+ LAPACKE_sggesx,
+ LAPACKE_sggesx_work,
+ LAPACKE_sggev,
+ LAPACKE_sggev_work,
+ LAPACKE_sggevx,
+ LAPACKE_sggevx_work,
+ LAPACKE_sggglm,
+ LAPACKE_sggglm_work,
+ LAPACKE_sgghrd,
+ LAPACKE_sgghrd_work,
+ LAPACKE_sgglse,
+ LAPACKE_sgglse_work,
+ LAPACKE_sggqrf,
+ LAPACKE_sggqrf_work,
+ LAPACKE_sggrqf,
+ LAPACKE_sggrqf_work,
+ LAPACKE_sggsvd,
+ LAPACKE_sggsvd_work,
+ LAPACKE_sggsvp,
+ LAPACKE_sggsvp_work,
+ LAPACKE_sgtcon,
+ LAPACKE_sgtcon_work,
+ LAPACKE_sgtrfs,
+ LAPACKE_sgtrfs_work,
+ LAPACKE_sgtsv,
+ LAPACKE_sgtsv_work,
+ LAPACKE_sgtsvx,
+ LAPACKE_sgtsvx_work,
+ LAPACKE_sgttrf,
+ LAPACKE_sgttrf_work,
+ LAPACKE_sgttrs,
+ LAPACKE_sgttrs_work,
+ LAPACKE_shgeqz,
+ LAPACKE_shgeqz_work,
+ LAPACKE_shsein,
+ LAPACKE_shsein_work,
+ LAPACKE_shseqr,
+ LAPACKE_shseqr_work,
+ LAPACKE_slacn2,
+ LAPACKE_slacn2_work,
+ LAPACKE_slacpy,
+ LAPACKE_slacpy_work,
+ LAPACKE_slag2d,
+ LAPACKE_slag2d_work,
+ LAPACKE_slamch,
+ LAPACKE_slamch_work,
+ LAPACKE_slange,
+ LAPACKE_slange_work,
+ LAPACKE_slansy,
+ LAPACKE_slansy_work,
+ LAPACKE_slantr,
+ LAPACKE_slantr_work,
+ LAPACKE_slapmr,
+ LAPACKE_slapmr_work,
+ LAPACKE_slapy2,
+ LAPACKE_slapy2_work,
+ LAPACKE_slapy3,
+ LAPACKE_slapy3_work,
+ LAPACKE_slarfb,
+ LAPACKE_slarfb_work,
+ LAPACKE_slarfg,
+ LAPACKE_slarfg_work,
+ LAPACKE_slarft,
+ LAPACKE_slarft_work,
+ LAPACKE_slarfx,
+ LAPACKE_slarfx_work,
+ LAPACKE_slarnv,
+ LAPACKE_slarnv_work,
+ LAPACKE_slartgp,
+ LAPACKE_slartgp_work,
+ LAPACKE_slartgs,
+ LAPACKE_slartgs_work,
+ LAPACKE_slaset,
+ LAPACKE_slaset_work,
+ LAPACKE_slasrt,
+ LAPACKE_slasrt_work,
+ LAPACKE_slaswp,
+ LAPACKE_slaswp_work,
+ LAPACKE_slauum,
+ LAPACKE_slauum_work,
+ LAPACKE_sopgtr,
+ LAPACKE_sopgtr_work,
+ LAPACKE_sopmtr,
+ LAPACKE_sopmtr_work,
+ LAPACKE_sorbdb,
+ LAPACKE_sorbdb_work,
+ LAPACKE_sorcsd,
+ LAPACKE_sorcsd_work,
+ LAPACKE_sorgbr,
+ LAPACKE_sorgbr_work,
+ LAPACKE_sorghr,
+ LAPACKE_sorghr_work,
+ LAPACKE_sorglq,
+ LAPACKE_sorglq_work,
+ LAPACKE_sorgql,
+ LAPACKE_sorgql_work,
+ LAPACKE_sorgqr,
+ LAPACKE_sorgqr_work,
+ LAPACKE_sorgrq,
+ LAPACKE_sorgrq_work,
+ LAPACKE_sorgtr,
+ LAPACKE_sorgtr_work,
+ LAPACKE_sormbr,
+ LAPACKE_sormbr_work,
+ LAPACKE_sormhr,
+ LAPACKE_sormhr_work,
+ LAPACKE_sormlq,
+ LAPACKE_sormlq_work,
+ LAPACKE_sormql,
+ LAPACKE_sormql_work,
+ LAPACKE_sormqr,
+ LAPACKE_sormqr_work,
+ LAPACKE_sormrq,
+ LAPACKE_sormrq_work,
+ LAPACKE_sormrz,
+ LAPACKE_sormrz_work,
+ LAPACKE_sormtr,
+ LAPACKE_sormtr_work,
+ LAPACKE_spbcon,
+ LAPACKE_spbcon_work,
+ LAPACKE_spbequ,
+ LAPACKE_spbequ_work,
+ LAPACKE_spbrfs,
+ LAPACKE_spbrfs_work,
+ LAPACKE_spbstf,
+ LAPACKE_spbstf_work,
+ LAPACKE_spbsv,
+ LAPACKE_spbsv_work,
+ LAPACKE_spbsvx,
+ LAPACKE_spbsvx_work,
+ LAPACKE_spbtrf,
+ LAPACKE_spbtrf_work,
+ LAPACKE_spbtrs,
+ LAPACKE_spbtrs_work,
+ LAPACKE_spftrf,
+ LAPACKE_spftrf_work,
+ LAPACKE_spftri,
+ LAPACKE_spftri_work,
+ LAPACKE_spftrs,
+ LAPACKE_spftrs_work,
+ LAPACKE_spocon,
+ LAPACKE_spocon_work,
+ LAPACKE_spoequ,
+ LAPACKE_spoequ_work,
+ LAPACKE_spoequb,
+ LAPACKE_spoequb_work,
+ LAPACKE_sporfs,
+ LAPACKE_sporfs_work,
+ LAPACKE_sposv,
+ LAPACKE_sposv_work,
+ LAPACKE_sposvx,
+ LAPACKE_sposvx_work,
+ LAPACKE_spotrf,
+ LAPACKE_spotrf_work,
+ LAPACKE_spotri,
+ LAPACKE_spotri_work,
+ LAPACKE_spotrs,
+ LAPACKE_spotrs_work,
+ LAPACKE_sppcon,
+ LAPACKE_sppcon_work,
+ LAPACKE_sppequ,
+ LAPACKE_sppequ_work,
+ LAPACKE_spprfs,
+ LAPACKE_spprfs_work,
+ LAPACKE_sppsv,
+ LAPACKE_sppsv_work,
+ LAPACKE_sppsvx,
+ LAPACKE_sppsvx_work,
+ LAPACKE_spptrf,
+ LAPACKE_spptrf_work,
+ LAPACKE_spptri,
+ LAPACKE_spptri_work,
+ LAPACKE_spptrs,
+ LAPACKE_spptrs_work,
+ LAPACKE_spstrf,
+ LAPACKE_spstrf_work,
+ LAPACKE_sptcon,
+ LAPACKE_sptcon_work,
+ LAPACKE_spteqr,
+ LAPACKE_spteqr_work,
+ LAPACKE_sptrfs,
+ LAPACKE_sptrfs_work,
+ LAPACKE_sptsv,
+ LAPACKE_sptsv_work,
+ LAPACKE_sptsvx,
+ LAPACKE_sptsvx_work,
+ LAPACKE_spttrf,
+ LAPACKE_spttrf_work,
+ LAPACKE_spttrs,
+ LAPACKE_spttrs_work,
+ LAPACKE_ssbev,
+ LAPACKE_ssbev_work,
+ LAPACKE_ssbevd,
+ LAPACKE_ssbevd_work,
+ LAPACKE_ssbevx,
+ LAPACKE_ssbevx_work,
+ LAPACKE_ssbgst,
+ LAPACKE_ssbgst_work,
+ LAPACKE_ssbgv,
+ LAPACKE_ssbgv_work,
+ LAPACKE_ssbgvd,
+ LAPACKE_ssbgvd_work,
+ LAPACKE_ssbgvx,
+ LAPACKE_ssbgvx_work,
+ LAPACKE_ssbtrd,
+ LAPACKE_ssbtrd_work,
+ LAPACKE_ssfrk,
+ LAPACKE_ssfrk_work,
+ LAPACKE_sspcon,
+ LAPACKE_sspcon_work,
+ LAPACKE_sspev,
+ LAPACKE_sspev_work,
+ LAPACKE_sspevd,
+ LAPACKE_sspevd_work,
+ LAPACKE_sspevx,
+ LAPACKE_sspevx_work,
+ LAPACKE_sspgst,
+ LAPACKE_sspgst_work,
+ LAPACKE_sspgv,
+ LAPACKE_sspgv_work,
+ LAPACKE_sspgvd,
+ LAPACKE_sspgvd_work,
+ LAPACKE_sspgvx,
+ LAPACKE_sspgvx_work,
+ LAPACKE_ssprfs,
+ LAPACKE_ssprfs_work,
+ LAPACKE_sspsv,
+ LAPACKE_sspsv_work,
+ LAPACKE_sspsvx,
+ LAPACKE_sspsvx_work,
+ LAPACKE_ssptrd,
+ LAPACKE_ssptrd_work,
+ LAPACKE_ssptrf,
+ LAPACKE_ssptrf_work,
+ LAPACKE_ssptri,
+ LAPACKE_ssptri_work,
+ LAPACKE_ssptrs,
+ LAPACKE_ssptrs_work,
+ LAPACKE_sstebz,
+ LAPACKE_sstebz_work,
+ LAPACKE_sstedc,
+ LAPACKE_sstedc_work,
+ LAPACKE_sstegr,
+ LAPACKE_sstegr_work,
+ LAPACKE_sstein,
+ LAPACKE_sstein_work,
+ LAPACKE_sstemr,
+ LAPACKE_sstemr_work,
+ LAPACKE_ssteqr,
+ LAPACKE_ssteqr_work,
+ LAPACKE_ssterf,
+ LAPACKE_ssterf_work,
+ LAPACKE_sstev,
+ LAPACKE_sstev_work,
+ LAPACKE_sstevd,
+ LAPACKE_sstevd_work,
+ LAPACKE_sstevr,
+ LAPACKE_sstevr_work,
+ LAPACKE_sstevx,
+ LAPACKE_sstevx_work,
+ LAPACKE_ssycon,
+ LAPACKE_ssycon_work,
+ LAPACKE_ssyconv,
+ LAPACKE_ssyconv_work,
+ LAPACKE_ssyequb,
+ LAPACKE_ssyequb_work,
+ LAPACKE_ssyev,
+ LAPACKE_ssyev_work,
+ LAPACKE_ssyevd,
+ LAPACKE_ssyevd_work,
+ LAPACKE_ssyevr,
+ LAPACKE_ssyevr_work,
+ LAPACKE_ssyevx,
+ LAPACKE_ssyevx_work,
+ LAPACKE_ssygst,
+ LAPACKE_ssygst_work,
+ LAPACKE_ssygv,
+ LAPACKE_ssygv_work,
+ LAPACKE_ssygvd,
+ LAPACKE_ssygvd_work,
+ LAPACKE_ssygvx,
+ LAPACKE_ssygvx_work,
+ LAPACKE_ssyrfs,
+ LAPACKE_ssyrfs_work,
+ LAPACKE_ssysv,
+ LAPACKE_ssysv_rook,
+ LAPACKE_ssysv_rook_work,
+ LAPACKE_ssysv_work,
+ LAPACKE_ssysvx,
+ LAPACKE_ssysvx_work,
+ LAPACKE_ssyswapr,
+ LAPACKE_ssyswapr_work,
+ LAPACKE_ssytrd,
+ LAPACKE_ssytrd_work,
+ LAPACKE_ssytrf,
+ LAPACKE_ssytrf_work,
+ LAPACKE_ssytri,
+ LAPACKE_ssytri2,
+ LAPACKE_ssytri2_work,
+ LAPACKE_ssytri2x,
+ LAPACKE_ssytri2x_work,
+ LAPACKE_ssytri_work,
+ LAPACKE_ssytrs,
+ LAPACKE_ssytrs2,
+ LAPACKE_ssytrs2_work,
+ LAPACKE_ssytrs_work,
+ LAPACKE_stbcon,
+ LAPACKE_stbcon_work,
+ LAPACKE_stbrfs,
+ LAPACKE_stbrfs_work,
+ LAPACKE_stbtrs,
+ LAPACKE_stbtrs_work,
+ LAPACKE_stfsm,
+ LAPACKE_stfsm_work,
+ LAPACKE_stftri,
+ LAPACKE_stftri_work,
+ LAPACKE_stfttp,
+ LAPACKE_stfttp_work,
+ LAPACKE_stfttr,
+ LAPACKE_stfttr_work,
+ LAPACKE_stgevc,
+ LAPACKE_stgevc_work,
+ LAPACKE_stgexc,
+ LAPACKE_stgexc_work,
+ LAPACKE_stgsen,
+ LAPACKE_stgsen_work,
+ LAPACKE_stgsja,
+ LAPACKE_stgsja_work,
+ LAPACKE_stgsna,
+ LAPACKE_stgsna_work,
+ LAPACKE_stgsyl,
+ LAPACKE_stgsyl_work,
+ LAPACKE_stpcon,
+ LAPACKE_stpcon_work,
+ LAPACKE_stpmqrt,
+ LAPACKE_stpmqrt_work,
+ LAPACKE_stpqrt2,
+ LAPACKE_stpqrt2_work,
+ LAPACKE_stprfb,
+ LAPACKE_stprfb_work,
+ LAPACKE_stprfs,
+ LAPACKE_stprfs_work,
+ LAPACKE_stptri,
+ LAPACKE_stptri_work,
+ LAPACKE_stptrs,
+ LAPACKE_stptrs_work,
+ LAPACKE_stpttf,
+ LAPACKE_stpttf_work,
+ LAPACKE_stpttr,
+ LAPACKE_stpttr_work,
+ LAPACKE_strcon,
+ LAPACKE_strcon_work,
+ LAPACKE_strevc,
+ LAPACKE_strevc_work,
+ LAPACKE_strexc,
+ LAPACKE_strexc_work,
+ LAPACKE_strrfs,
+ LAPACKE_strrfs_work,
+ LAPACKE_strsen,
+ LAPACKE_strsen_work,
+ LAPACKE_strsna,
+ LAPACKE_strsna_work,
+ LAPACKE_strsyl,
+ LAPACKE_strsyl_work,
+ LAPACKE_strtri,
+ LAPACKE_strtri_work,
+ LAPACKE_strtrs,
+ LAPACKE_strtrs_work,
+ LAPACKE_strttf,
+ LAPACKE_strttf_work,
+ LAPACKE_strttp,
+ LAPACKE_strttp_work,
+ LAPACKE_stzrzf,
+ LAPACKE_stzrzf_work,
+ LAPACKE_zbbcsd,
+ LAPACKE_zbbcsd_work,
+ LAPACKE_zbdsqr,
+ LAPACKE_zbdsqr_work,
+ LAPACKE_zcgesv,
+ LAPACKE_zcgesv_work,
+ LAPACKE_zcposv,
+ LAPACKE_zcposv_work,
+ LAPACKE_zgbbrd,
+ LAPACKE_zgbbrd_work,
+ LAPACKE_zgbcon,
+ LAPACKE_zgbcon_work,
+ LAPACKE_zgbequ,
+ LAPACKE_zgbequ_work,
+ LAPACKE_zgbequb,
+ LAPACKE_zgbequb_work,
+ LAPACKE_zgbrfs,
+ LAPACKE_zgbrfs_work,
+ LAPACKE_zgbsv,
+ LAPACKE_zgbsv_work,
+ LAPACKE_zgbsvx,
+ LAPACKE_zgbsvx_work,
+ LAPACKE_zgbtrf,
+ LAPACKE_zgbtrf_work,
+ LAPACKE_zgbtrs,
+ LAPACKE_zgbtrs_work,
+ LAPACKE_zgebak,
+ LAPACKE_zgebak_work,
+ LAPACKE_zgebal,
+ LAPACKE_zgebal_work,
+ LAPACKE_zgebrd,
+ LAPACKE_zgebrd_work,
+ LAPACKE_zgecon,
+ LAPACKE_zgecon_work,
+ LAPACKE_zgeequ,
+ LAPACKE_zgeequ_work,
+ LAPACKE_zgeequb,
+ LAPACKE_zgeequb_work,
+ LAPACKE_zgees,
+ LAPACKE_zgees_work,
+ LAPACKE_zgeesx,
+ LAPACKE_zgeesx_work,
+ LAPACKE_zgeev,
+ LAPACKE_zgeev_work,
+ LAPACKE_zgeevx,
+ LAPACKE_zgeevx_work,
+ LAPACKE_zgehrd,
+ LAPACKE_zgehrd_work,
+ LAPACKE_zgelq2,
+ LAPACKE_zgelq2_work,
+ LAPACKE_zgelqf,
+ LAPACKE_zgelqf_work,
+ LAPACKE_zgels,
+ LAPACKE_zgels_work,
+ LAPACKE_zgelsd,
+ LAPACKE_zgelsd_work,
+ LAPACKE_zgelss,
+ LAPACKE_zgelss_work,
+ LAPACKE_zgelsy,
+ LAPACKE_zgelsy_work,
+ LAPACKE_zgemqrt,
+ LAPACKE_zgemqrt_work,
+ LAPACKE_zgeqlf,
+ LAPACKE_zgeqlf_work,
+ LAPACKE_zgeqp3,
+ LAPACKE_zgeqp3_work,
+ LAPACKE_zgeqpf,
+ LAPACKE_zgeqpf_work,
+ LAPACKE_zgeqr2,
+ LAPACKE_zgeqr2_work,
+ LAPACKE_zgeqrf,
+ LAPACKE_zgeqrf_work,
+ LAPACKE_zgeqrfp,
+ LAPACKE_zgeqrfp_work,
+ LAPACKE_zgeqrt,
+ LAPACKE_zgeqrt2,
+ LAPACKE_zgeqrt2_work,
+ LAPACKE_zgeqrt3,
+ LAPACKE_zgeqrt3_work,
+ LAPACKE_zgeqrt_work,
+ LAPACKE_zgerfs,
+ LAPACKE_zgerfs_work,
+ LAPACKE_zgerqf,
+ LAPACKE_zgerqf_work,
+ LAPACKE_zgesdd,
+ LAPACKE_zgesdd_work,
+ LAPACKE_zgesv,
+ LAPACKE_zgesv_work,
+ LAPACKE_zgesvd,
+ LAPACKE_zgesvd_work,
+ LAPACKE_zgesvx,
+ LAPACKE_zgesvx_work,
+ LAPACKE_zgetf2,
+ LAPACKE_zgetf2_work,
+ LAPACKE_zgetrf,
+ LAPACKE_zgetrf_work,
+ LAPACKE_zgetri,
+ LAPACKE_zgetri_work,
+ LAPACKE_zgetrs,
+ LAPACKE_zgetrs_work,
+ LAPACKE_zggbak,
+ LAPACKE_zggbak_work,
+ LAPACKE_zggbal,
+ LAPACKE_zggbal_work,
+ LAPACKE_zgges,
+ LAPACKE_zgges_work,
+ LAPACKE_zggesx,
+ LAPACKE_zggesx_work,
+ LAPACKE_zggev,
+ LAPACKE_zggev_work,
+ LAPACKE_zggevx,
+ LAPACKE_zggevx_work,
+ LAPACKE_zggglm,
+ LAPACKE_zggglm_work,
+ LAPACKE_zgghrd,
+ LAPACKE_zgghrd_work,
+ LAPACKE_zgglse,
+ LAPACKE_zgglse_work,
+ LAPACKE_zggqrf,
+ LAPACKE_zggqrf_work,
+ LAPACKE_zggrqf,
+ LAPACKE_zggrqf_work,
+ LAPACKE_zggsvd,
+ LAPACKE_zggsvd_work,
+ LAPACKE_zggsvp,
+ LAPACKE_zggsvp_work,
+ LAPACKE_zgtcon,
+ LAPACKE_zgtcon_work,
+ LAPACKE_zgtrfs,
+ LAPACKE_zgtrfs_work,
+ LAPACKE_zgtsv,
+ LAPACKE_zgtsv_work,
+ LAPACKE_zgtsvx,
+ LAPACKE_zgtsvx_work,
+ LAPACKE_zgttrf,
+ LAPACKE_zgttrf_work,
+ LAPACKE_zgttrs,
+ LAPACKE_zgttrs_work,
+ LAPACKE_zhbev,
+ LAPACKE_zhbev_work,
+ LAPACKE_zhbevd,
+ LAPACKE_zhbevd_work,
+ LAPACKE_zhbevx,
+ LAPACKE_zhbevx_work,
+ LAPACKE_zhbgst,
+ LAPACKE_zhbgst_work,
+ LAPACKE_zhbgv,
+ LAPACKE_zhbgv_work,
+ LAPACKE_zhbgvd,
+ LAPACKE_zhbgvd_work,
+ LAPACKE_zhbgvx,
+ LAPACKE_zhbgvx_work,
+ LAPACKE_zhbtrd,
+ LAPACKE_zhbtrd_work,
+ LAPACKE_zhecon,
+ LAPACKE_zhecon_work,
+ LAPACKE_zheequb,
+ LAPACKE_zheequb_work,
+ LAPACKE_zheev,
+ LAPACKE_zheev_work,
+ LAPACKE_zheevd,
+ LAPACKE_zheevd_work,
+ LAPACKE_zheevr,
+ LAPACKE_zheevr_work,
+ LAPACKE_zheevx,
+ LAPACKE_zheevx_work,
+ LAPACKE_zhegst,
+ LAPACKE_zhegst_work,
+ LAPACKE_zhegv,
+ LAPACKE_zhegv_work,
+ LAPACKE_zhegvd,
+ LAPACKE_zhegvd_work,
+ LAPACKE_zhegvx,
+ LAPACKE_zhegvx_work,
+ LAPACKE_zherfs,
+ LAPACKE_zherfs_work,
+ LAPACKE_zhesv,
+ LAPACKE_zhesv_work,
+ LAPACKE_zhesvx,
+ LAPACKE_zhesvx_work,
+ LAPACKE_zheswapr,
+ LAPACKE_zheswapr_work,
+ LAPACKE_zhetrd,
+ LAPACKE_zhetrd_work,
+ LAPACKE_zhetrf,
+ LAPACKE_zhetrf_work,
+ LAPACKE_zhetri,
+ LAPACKE_zhetri2,
+ LAPACKE_zhetri2_work,
+ LAPACKE_zhetri2x,
+ LAPACKE_zhetri2x_work,
+ LAPACKE_zhetri_work,
+ LAPACKE_zhetrs,
+ LAPACKE_zhetrs2,
+ LAPACKE_zhetrs2_work,
+ LAPACKE_zhetrs_work,
+ LAPACKE_zhfrk,
+ LAPACKE_zhfrk_work,
+ LAPACKE_zhgeqz,
+ LAPACKE_zhgeqz_work,
+ LAPACKE_zhpcon,
+ LAPACKE_zhpcon_work,
+ LAPACKE_zhpev,
+ LAPACKE_zhpev_work,
+ LAPACKE_zhpevd,
+ LAPACKE_zhpevd_work,
+ LAPACKE_zhpevx,
+ LAPACKE_zhpevx_work,
+ LAPACKE_zhpgst,
+ LAPACKE_zhpgst_work,
+ LAPACKE_zhpgv,
+ LAPACKE_zhpgv_work,
+ LAPACKE_zhpgvd,
+ LAPACKE_zhpgvd_work,
+ LAPACKE_zhpgvx,
+ LAPACKE_zhpgvx_work,
+ LAPACKE_zhprfs,
+ LAPACKE_zhprfs_work,
+ LAPACKE_zhpsv,
+ LAPACKE_zhpsv_work,
+ LAPACKE_zhpsvx,
+ LAPACKE_zhpsvx_work,
+ LAPACKE_zhptrd,
+ LAPACKE_zhptrd_work,
+ LAPACKE_zhptrf,
+ LAPACKE_zhptrf_work,
+ LAPACKE_zhptri,
+ LAPACKE_zhptri_work,
+ LAPACKE_zhptrs,
+ LAPACKE_zhptrs_work,
+ LAPACKE_zhsein,
+ LAPACKE_zhsein_work,
+ LAPACKE_zhseqr,
+ LAPACKE_zhseqr_work,
+ LAPACKE_zlacgv,
+ LAPACKE_zlacgv_work,
+ LAPACKE_zlacn2,
+ LAPACKE_zlacn2_work,
+ LAPACKE_zlacp2,
+ LAPACKE_zlacp2_work,
+ LAPACKE_zlacpy,
+ LAPACKE_zlacpy_work,
+ LAPACKE_zlag2c,
+ LAPACKE_zlag2c_work,
+ LAPACKE_zlange,
+ LAPACKE_zlange_work,
+ LAPACKE_zlanhe,
+ LAPACKE_zlanhe_work,
+ LAPACKE_zlansy,
+ LAPACKE_zlansy_work,
+ LAPACKE_zlantr,
+ LAPACKE_zlantr_work,
+ LAPACKE_zlapmr,
+ LAPACKE_zlapmr_work,
+ LAPACKE_zlarfb,
+ LAPACKE_zlarfb_work,
+ LAPACKE_zlarfg,
+ LAPACKE_zlarfg_work,
+ LAPACKE_zlarft,
+ LAPACKE_zlarft_work,
+ LAPACKE_zlarfx,
+ LAPACKE_zlarfx_work,
+ LAPACKE_zlarnv,
+ LAPACKE_zlarnv_work,
+ LAPACKE_zlaset,
+ LAPACKE_zlaset_work,
+ LAPACKE_zlaswp,
+ LAPACKE_zlaswp_work,
+ LAPACKE_zlauum,
+ LAPACKE_zlauum_work,
+ LAPACKE_zpbcon,
+ LAPACKE_zpbcon_work,
+ LAPACKE_zpbequ,
+ LAPACKE_zpbequ_work,
+ LAPACKE_zpbrfs,
+ LAPACKE_zpbrfs_work,
+ LAPACKE_zpbstf,
+ LAPACKE_zpbstf_work,
+ LAPACKE_zpbsv,
+ LAPACKE_zpbsv_work,
+ LAPACKE_zpbsvx,
+ LAPACKE_zpbsvx_work,
+ LAPACKE_zpbtrf,
+ LAPACKE_zpbtrf_work,
+ LAPACKE_zpbtrs,
+ LAPACKE_zpbtrs_work,
+ LAPACKE_zpftrf,
+ LAPACKE_zpftrf_work,
+ LAPACKE_zpftri,
+ LAPACKE_zpftri_work,
+ LAPACKE_zpftrs,
+ LAPACKE_zpftrs_work,
+ LAPACKE_zpocon,
+ LAPACKE_zpocon_work,
+ LAPACKE_zpoequ,
+ LAPACKE_zpoequ_work,
+ LAPACKE_zpoequb,
+ LAPACKE_zpoequb_work,
+ LAPACKE_zporfs,
+ LAPACKE_zporfs_work,
+ LAPACKE_zposv,
+ LAPACKE_zposv_work,
+ LAPACKE_zposvx,
+ LAPACKE_zposvx_work,
+ LAPACKE_zpotrf,
+ LAPACKE_zpotrf_work,
+ LAPACKE_zpotri,
+ LAPACKE_zpotri_work,
+ LAPACKE_zpotrs,
+ LAPACKE_zpotrs_work,
+ LAPACKE_zppcon,
+ LAPACKE_zppcon_work,
+ LAPACKE_zppequ,
+ LAPACKE_zppequ_work,
+ LAPACKE_zpprfs,
+ LAPACKE_zpprfs_work,
+ LAPACKE_zppsv,
+ LAPACKE_zppsv_work,
+ LAPACKE_zppsvx,
+ LAPACKE_zppsvx_work,
+ LAPACKE_zpptrf,
+ LAPACKE_zpptrf_work,
+ LAPACKE_zpptri,
+ LAPACKE_zpptri_work,
+ LAPACKE_zpptrs,
+ LAPACKE_zpptrs_work,
+ LAPACKE_zpstrf,
+ LAPACKE_zpstrf_work,
+ LAPACKE_zptcon,
+ LAPACKE_zptcon_work,
+ LAPACKE_zpteqr,
+ LAPACKE_zpteqr_work,
+ LAPACKE_zptrfs,
+ LAPACKE_zptrfs_work,
+ LAPACKE_zptsv,
+ LAPACKE_zptsv_work,
+ LAPACKE_zptsvx,
+ LAPACKE_zptsvx_work,
+ LAPACKE_zpttrf,
+ LAPACKE_zpttrf_work,
+ LAPACKE_zpttrs,
+ LAPACKE_zpttrs_work,
+ LAPACKE_zspcon,
+ LAPACKE_zspcon_work,
+ LAPACKE_zsprfs,
+ LAPACKE_zsprfs_work,
+ LAPACKE_zspsv,
+ LAPACKE_zspsv_work,
+ LAPACKE_zspsvx,
+ LAPACKE_zspsvx_work,
+ LAPACKE_zsptrf,
+ LAPACKE_zsptrf_work,
+ LAPACKE_zsptri,
+ LAPACKE_zsptri_work,
+ LAPACKE_zsptrs,
+ LAPACKE_zsptrs_work,
+ LAPACKE_zstedc,
+ LAPACKE_zstedc_work,
+ LAPACKE_zstegr,
+ LAPACKE_zstegr_work,
+ LAPACKE_zstein,
+ LAPACKE_zstein_work,
+ LAPACKE_zstemr,
+ LAPACKE_zstemr_work,
+ LAPACKE_zsteqr,
+ LAPACKE_zsteqr_work,
+ LAPACKE_zsycon,
+ LAPACKE_zsycon_work,
+ LAPACKE_zsyconv,
+ LAPACKE_zsyconv_work,
+ LAPACKE_zsyequb,
+ LAPACKE_zsyequb_work,
+ LAPACKE_zsyrfs,
+ LAPACKE_zsyrfs_work,
+ LAPACKE_zsysv,
+ LAPACKE_zsysv_rook,
+ LAPACKE_zsysv_rook_work,
+ LAPACKE_zsysv_work,
+ LAPACKE_zsysvx,
+ LAPACKE_zsysvx_work,
+ LAPACKE_zsyswapr,
+ LAPACKE_zsyswapr_work,
+ LAPACKE_zsytrf,
+ LAPACKE_zsytrf_work,
+ LAPACKE_zsytri,
+ LAPACKE_zsytri2,
+ LAPACKE_zsytri2_work,
+ LAPACKE_zsytri2x,
+ LAPACKE_zsytri2x_work,
+ LAPACKE_zsytri_work,
+ LAPACKE_zsytrs,
+ LAPACKE_zsytrs2,
+ LAPACKE_zsytrs2_work,
+ LAPACKE_zsytrs_work,
+ LAPACKE_ztbcon,
+ LAPACKE_ztbcon_work,
+ LAPACKE_ztbrfs,
+ LAPACKE_ztbrfs_work,
+ LAPACKE_ztbtrs,
+ LAPACKE_ztbtrs_work,
+ LAPACKE_ztfsm,
+ LAPACKE_ztfsm_work,
+ LAPACKE_ztftri,
+ LAPACKE_ztftri_work,
+ LAPACKE_ztfttp,
+ LAPACKE_ztfttp_work,
+ LAPACKE_ztfttr,
+ LAPACKE_ztfttr_work,
+ LAPACKE_ztgevc,
+ LAPACKE_ztgevc_work,
+ LAPACKE_ztgexc,
+ LAPACKE_ztgexc_work,
+ LAPACKE_ztgsen,
+ LAPACKE_ztgsen_work,
+ LAPACKE_ztgsja,
+ LAPACKE_ztgsja_work,
+ LAPACKE_ztgsna,
+ LAPACKE_ztgsna_work,
+ LAPACKE_ztgsyl,
+ LAPACKE_ztgsyl_work,
+ LAPACKE_ztpcon,
+ LAPACKE_ztpcon_work,
+ LAPACKE_ztpmqrt,
+ LAPACKE_ztpmqrt_work,
+ LAPACKE_ztpqrt,
+ LAPACKE_ztpqrt2,
+ LAPACKE_ztpqrt2_work,
+ LAPACKE_ztpqrt_work,
+ LAPACKE_ztprfb,
+ LAPACKE_ztprfb_work,
+ LAPACKE_ztprfs,
+ LAPACKE_ztprfs_work,
+ LAPACKE_ztptri,
+ LAPACKE_ztptri_work,
+ LAPACKE_ztptrs,
+ LAPACKE_ztptrs_work,
+ LAPACKE_ztpttf,
+ LAPACKE_ztpttf_work,
+ LAPACKE_ztpttr,
+ LAPACKE_ztpttr_work,
+ LAPACKE_ztrcon,
+ LAPACKE_ztrcon_work,
+ LAPACKE_ztrevc,
+ LAPACKE_ztrevc_work,
+ LAPACKE_ztrexc,
+ LAPACKE_ztrexc_work,
+ LAPACKE_ztrrfs,
+ LAPACKE_ztrrfs_work,
+ LAPACKE_ztrsen,
+ LAPACKE_ztrsen_work,
+ LAPACKE_ztrsna,
+ LAPACKE_ztrsna_work,
+ LAPACKE_ztrsyl,
+ LAPACKE_ztrsyl_work,
+ LAPACKE_ztrtri,
+ LAPACKE_ztrtri_work,
+ LAPACKE_ztrtrs,
+ LAPACKE_ztrtrs_work,
+ LAPACKE_ztrttf,
+ LAPACKE_ztrttf_work,
+ LAPACKE_ztrttp,
+ LAPACKE_ztrttp_work,
+ LAPACKE_ztzrzf,
+ LAPACKE_ztzrzf_work,
+ LAPACKE_zunbdb,
+ LAPACKE_zunbdb_work,
+ LAPACKE_zuncsd,
+ LAPACKE_zuncsd_work,
+ LAPACKE_zungbr,
+ LAPACKE_zungbr_work,
+ LAPACKE_zunghr,
+ LAPACKE_zunghr_work,
+ LAPACKE_zunglq,
+ LAPACKE_zunglq_work,
+ LAPACKE_zungql,
+ LAPACKE_zungql_work,
+ LAPACKE_zungqr,
+ LAPACKE_zungqr_work,
+ LAPACKE_zungrq,
+ LAPACKE_zungrq_work,
+ LAPACKE_zungtr,
+ LAPACKE_zungtr_work,
+ LAPACKE_zunmbr,
+ LAPACKE_zunmbr_work,
+ LAPACKE_zunmhr,
+ LAPACKE_zunmhr_work,
+ LAPACKE_zunmlq,
+ LAPACKE_zunmlq_work,
+ LAPACKE_zunmql,
+ LAPACKE_zunmql_work,
+ LAPACKE_zunmqr,
+ LAPACKE_zunmqr_work,
+ LAPACKE_zunmrq,
+ LAPACKE_zunmrq_work,
+ LAPACKE_zunmrz,
+ LAPACKE_zunmrz_work,
+ LAPACKE_zunmtr,
+ LAPACKE_zunmtr_work,
+ LAPACKE_zupgtr,
+ LAPACKE_zupgtr_work,
+ LAPACKE_zupmtr,
+ LAPACKE_zupmtr_work,
+ LAPACKE_zsyr,
+ LAPACKE_csyr,
+ LAPACKE_zsyr_work,
+ LAPACKE_csyr_work,
+ LAPACKE_ilaver,
## @(SRCX_OBJ) from `lapack-3.4.1/lapacke/src/Makefile`
## Not exported: requires LAPACKE_EXTENDED to be set and depends on the
@@ -2673,7 +2698,26 @@
);
#These function may need 2 underscores.
-@lapack_embeded_underscore_objs=(xerbla_array, chla_transtype,);
+@lapack_embeded_underscore_objs=(xerbla_array, chla_transtype, slasyf_rook,
+ ssytf2_rook, ssytrf_rook, ssytrs_rook,
+ ssytri_rook, ssycon_rook, ssysv_rook,
+ chetf2_rook, chetrf_rook, chetri_rook,
+ chetrs_rook, checon_rook, chesv_rook,
+ clahef_rook, clasyf_rook,
+ csytf2_rook, csytrf_rook, csytrs_rook,
+ csytri_rook, csycon_rook, csysv_rook,
+ dlasyf_rook,
+ dsytf2_rook, dsytrf_rook, dsytrs_rook,
+ dsytri_rook, dsycon_rook, dsysv_rook,
+ zhetf2_rook, zhetrf_rook, zhetri_rook,
+ zhetrs_rook, zhecon_rook, zhesv_rook,
+ zlahef_rook, zlasyf_rook,
+ zsytf2_rook, zsytrf_rook, zsytrs_rook,
+ zsytri_rook, zsycon_rook, zsysv_rook,
+
+
+
+ );
if ($ARGV[8] == 1) {
#ONLY_CBLAS=1
diff --git a/lapack-netlib/CMakeLists.txt b/lapack-netlib/CMakeLists.txt
index 31f4d6c2c..56ecd2e61 100644
--- a/lapack-netlib/CMakeLists.txt
+++ b/lapack-netlib/CMakeLists.txt
@@ -188,6 +188,7 @@ else()
CACHE STRING "Linker flags for shared libs" FORCE)
endif( NOT LATESTLAPACK_FOUND )
+message(STATUS "BUILD TESTING : ${BUILD_TESTING}" )
if(BUILD_TESTING)
add_subdirectory(TESTING)
endif(BUILD_TESTING)
@@ -200,7 +201,7 @@ option(LAPACKE "Build LAPACKE" OFF)
# if LAPACKE_WITH_TMG is selected, we need to add those routines to LAPACKE
option(LAPACKE_WITH_TMG "Build LAPACKE with tmglib routines" OFF)
if (LAPACKE_WITH_TMG)
- option(LAPACKE "Build LAPACKE" ON)
+ set(LAPACKE ON)
if(NOT BUILD_TESTING)
add_subdirectory(TESTING/MATGEN)
endif(NOT BUILD_TESTING)
diff --git a/lapack-netlib/DOCS/Doxyfile b/lapack-netlib/DOCS/Doxyfile
index 9098aa87f..0925c3180 100644
--- a/lapack-netlib/DOCS/Doxyfile
+++ b/lapack-netlib/DOCS/Doxyfile
@@ -647,7 +647,7 @@ INPUT_ENCODING = UTF-8
# *.hxx *.hpp *.h++ *.idl *.odl *.cs *.php *.php3 *.inc *.m *.mm *.dox *.py
# *.f90 *.f *.for *.vhd *.vhdl
-FILE_PATTERNS = *.f
+FILE_PATTERNS = *
# The RECURSIVE tag can be used to turn specify whether or not subdirectories
# should be searched for input files as well. Possible values are YES and NO.
diff --git a/lapack-netlib/DOCS/psfig.tex b/lapack-netlib/DOCS/psfig.tex
deleted file mode 100644
index e1e65a92c..000000000
--- a/lapack-netlib/DOCS/psfig.tex
+++ /dev/null
@@ -1,391 +0,0 @@
-% Psfig/TeX Release 1.2
-% dvi2ps-li version
-%
-% All software, documentation, and related files in this distribution of
-% psfig/tex are Copyright 1987, 1988 Trevor J. Darrell
-%
-% Permission is granted for use and non-profit distribution of psfig/tex
-% providing that this notice be clearly maintained, but the right to
-% distribute any portion of psfig/tex for profit or as part of any commercial
-% product is specifically reserved for the author.
-%
-% $Header$
-% $Source$
-%
-% Thanks to Greg Hager (GDH) and Ned Batchelder for their contributions
-% to this project.
-%
-\catcode`\@=11\relax
-\newwrite\@unused
-\def\typeout#1{{\let\protect\string\immediate\write\@unused{#1}}}
-\typeout{psfig/tex 1.2-dvi2ps-li}
-
-%% Here's how you define your figure path. Should be set up with null
-%% default and a user useable definition.
-
-\def\figurepath{./}
-\def\psfigurepath#1{\edef\figurepath{#1}}
-
-%
-% @psdo control structure -- similar to Latex @for.
-% I redefined these with different names so that psfig can
-% be used with TeX as well as LaTeX, and so that it will not
-% be vunerable to future changes in LaTeX's internal
-% control structure,
-%
-\def\@nnil{\@nil}
-\def\@empty{}
-\def\@psdonoop#1\@@#2#3{}
-\def\@psdo#1:=#2\do#3{\edef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
- \expandafter\@psdoloop#2,\@nil,\@nil\@@#1{#3}\fi}
-\def\@psdoloop#1,#2,#3\@@#4#5{\def#4{#1}\ifx #4\@nnil \else
- #5\def#4{#2}\ifx #4\@nnil \else#5\@ipsdoloop #3\@@#4{#5}\fi\fi}
-\def\@ipsdoloop#1,#2\@@#3#4{\def#3{#1}\ifx #3\@nnil
- \let\@nextwhile=\@psdonoop \else
- #4\relax\let\@nextwhile=\@ipsdoloop\fi\@nextwhile#2\@@#3{#4}}
-\def\@tpsdo#1:=#2\do#3{\xdef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
- \@tpsdoloop#2\@nil\@nil\@@#1{#3}\fi}
-\def\@tpsdoloop#1#2\@@#3#4{\def#3{#1}\ifx #3\@nnil
- \let\@nextwhile=\@psdonoop \else
- #4\relax\let\@nextwhile=\@tpsdoloop\fi\@nextwhile#2\@@#3{#4}}
-%
-%
-\def\psdraft{
- \def\@psdraft{0}
- %\typeout{draft level now is \@psdraft \space . }
-}
-\def\psfull{
- \def\@psdraft{100}
- %\typeout{draft level now is \@psdraft \space . }
-}
-\psfull
-\newif\if@prologfile
-\newif\if@postlogfile
-\newif\if@noisy
-\def\pssilent{
- \@noisyfalse
-}
-\def\psnoisy{
- \@noisytrue
-}
-\psnoisy
-%%% These are for the option list.
-%%% A specification of the form a = b maps to calling \@p@@sa{b}
-\newif\if@bbllx
-\newif\if@bblly
-\newif\if@bburx
-\newif\if@bbury
-\newif\if@height
-\newif\if@width
-\newif\if@rheight
-\newif\if@rwidth
-\newif\if@clip
-\newif\if@verbose
-\def\@p@@sclip#1{\@cliptrue}
-
-%%% GDH 7/26/87 -- changed so that it first looks in the local directory,
-%%% then in a specified global directory for the ps file.
-
-\def\@p@@sfile#1{\def\@p@sfile{null}%
- \openin1=#1
- \ifeof1\closein1%
- \openin1=\figurepath#1
- \ifeof1\typeout{Error, File #1 not found}
- \else\closein1
- \edef\@p@sfile{\figurepath#1}%
- \fi%
- \else\closein1%
- \def\@p@sfile{#1}%
- \fi}
-\def\@p@@sfigure#1{\def\@p@sfile{null}%
- \openin1=#1
- \ifeof1\closein1%
- \openin1=\figurepath#1
- \ifeof1\typeout{Error, File #1 not found}
- \else\closein1
- \def\@p@sfile{\figurepath#1}%
- \fi%
- \else\closein1%
- \def\@p@sfile{#1}%
- \fi}
-
-\def\@p@@sbbllx#1{
- %\typeout{bbllx is #1}
- \@bbllxtrue
- \dimen100=#1
- \edef\@p@sbbllx{\number\dimen100}
-}
-\def\@p@@sbblly#1{
- %\typeout{bblly is #1}
- \@bbllytrue
- \dimen100=#1
- \edef\@p@sbblly{\number\dimen100}
-}
-\def\@p@@sbburx#1{
- %\typeout{bburx is #1}
- \@bburxtrue
- \dimen100=#1
- \edef\@p@sbburx{\number\dimen100}
-}
-\def\@p@@sbbury#1{
- %\typeout{bbury is #1}
- \@bburytrue
- \dimen100=#1
- \edef\@p@sbbury{\number\dimen100}
-}
-\def\@p@@sheight#1{
- \@heighttrue
- \dimen100=#1
- \edef\@p@sheight{\number\dimen100}
- %\typeout{Height is \@p@sheight}
-}
-\def\@p@@swidth#1{
- %\typeout{Width is #1}
- \@widthtrue
- \dimen100=#1
- \edef\@p@swidth{\number\dimen100}
-}
-\def\@p@@srheight#1{
- %\typeout{Reserved height is #1}
- \@rheighttrue
- \dimen100=#1
- \edef\@p@srheight{\number\dimen100}
-}
-\def\@p@@srwidth#1{
- %\typeout{Reserved width is #1}
- \@rwidthtrue
- \dimen100=#1
- \edef\@p@srwidth{\number\dimen100}
-}
-\def\@p@@ssilent#1{
- \@verbosefalse
-}
-\def\@p@@sprolog#1{\@prologfiletrue\def\@prologfileval{#1}}
-\def\@p@@spostlog#1{\@postlogfiletrue\def\@postlogfileval{#1}}
-\def\@cs@name#1{\csname #1\endcsname}
-\def\@setparms#1=#2,{\@cs@name{@p@@s#1}{#2}}
-%
-% initialize the defaults (size the size of the figure)
-%
-\def\ps@init@parms{
- \@bbllxfalse \@bbllyfalse
- \@bburxfalse \@bburyfalse
- \@heightfalse \@widthfalse
- \@rheightfalse \@rwidthfalse
- \def\@p@sbbllx{}\def\@p@sbblly{}
- \def\@p@sbburx{}\def\@p@sbbury{}
- \def\@p@sheight{}\def\@p@swidth{}
- \def\@p@srheight{}\def\@p@srwidth{}
- \def\@p@sfile{}
- \def\@p@scost{10}
- \def\@sc{}
- \@prologfilefalse
- \@postlogfilefalse
- \@clipfalse
- \if@noisy
- \@verbosetrue
- \else
- \@verbosefalse
- \fi
-
-}
-%
-% Go through the options setting things up.
-%
-\def\parse@ps@parms#1{
- \@psdo\@psfiga:=#1\do
- {\expandafter\@setparms\@psfiga,}}
-%
-% Compute bb height and width
-%
-\newif\ifno@bb
-\newif\ifnot@eof
-\newread\ps@stream
-\def\bb@missing{
- \if@verbose{
- \typeout{psfig: searching \@p@sfile \space for bounding box}
- }\fi
- \openin\ps@stream=\@p@sfile
- \no@bbtrue
- \not@eoftrue
- \catcode`\%=12
- \loop
- \read\ps@stream to \line@in
- \global\toks200=\expandafter{\line@in}
- \ifeof\ps@stream \not@eoffalse \fi
- %\typeout{ looking at :: \the\toks200 }
- \@bbtest{\toks200}
- \if@bbmatch\not@eoffalse\expandafter\bb@cull\the\toks200\fi
- \ifnot@eof \repeat
- \catcode`\%=14
-}
-\catcode`\%=12
-\newif\if@bbmatch
-\def\@bbtest#1{\expandafter\@a@\the#1%%BoundingBox:\@bbtest\@a@}
-\long\def\@a@#1%%BoundingBox:#2#3\@a@{\ifx\@bbtest#2\@bbmatchfalse\else\@bbmatchtrue\fi}
-\long\def\bb@cull#1 #2 #3 #4 #5 {
- \dimen100=#2 bp\edef\@p@sbbllx{\number\dimen100}
- \dimen100=#3 bp\edef\@p@sbblly{\number\dimen100}
- \dimen100=#4 bp\edef\@p@sbburx{\number\dimen100}
- \dimen100=#5 bp\edef\@p@sbbury{\number\dimen100}
- \no@bbfalse
-}
-\catcode`\%=14
-%
-\def\compute@bb{
- \no@bbfalse
- \if@bbllx \else \no@bbtrue \fi
- \if@bblly \else \no@bbtrue \fi
- \if@bburx \else \no@bbtrue \fi
- \if@bbury \else \no@bbtrue \fi
- \ifno@bb \bb@missing \fi
- \ifno@bb \typeout{FATAL ERROR: no bb supplied or found}
- \no-bb-error
- \fi
- %
- \count203=\@p@sbburx
- \count204=\@p@sbbury
- \advance\count203 by -\@p@sbbllx
- \advance\count204 by -\@p@sbblly
- \edef\@bbw{\number\count203}
- \edef\@bbh{\number\count204}
- %\typeout{ bbh = \@bbh, bbw = \@bbw }
-}
-%
-% \in@hundreds performs #1 * (#2 / #3) correct to the hundreds,
-% then leaves the result in @result
-%
-\def\in@hundreds#1#2#3{\count240=#2 \count241=#3
- \count100=\count240 % 100 is first digit #2/#3
- \divide\count100 by \count241
- \count101=\count100
- \multiply\count101 by \count241
- \advance\count240 by -\count101
- \multiply\count240 by 10
- \count101=\count240 %101 is second digit of #2/#3
- \divide\count101 by \count241
- \count102=\count101
- \multiply\count102 by \count241
- \advance\count240 by -\count102
- \multiply\count240 by 10
- \count102=\count240 % 102 is the third digit
- \divide\count102 by \count241
- \count200=#1\count205=0
- \count201=\count200
- \multiply\count201 by \count100
- \advance\count205 by \count201
- \count201=\count200
- \divide\count201 by 10
- \multiply\count201 by \count101
- \advance\count205 by \count201
- %
- \count201=\count200
- \divide\count201 by 100
- \multiply\count201 by \count102
- \advance\count205 by \count201
- %
- \edef\@result{\number\count205}
-}
-\def\compute@wfromh{
- % computing : width = height * (bbw / bbh)
- \in@hundreds{\@p@sheight}{\@bbw}{\@bbh}
- %\typeout{ \@p@sheight * \@bbw / \@bbh, = \@result }
- \edef\@p@swidth{\@result}
- %\typeout{w from h: width is \@p@swidth}
-}
-\def\compute@hfromw{
- % computing : height = width * (bbh / bbw)
- \in@hundreds{\@p@swidth}{\@bbh}{\@bbw}
- %\typeout{ \@p@swidth * \@bbh / \@bbw = \@result }
- \edef\@p@sheight{\@result}
- %\typeout{h from w : height is \@p@sheight}
-}
-\def\compute@handw{
- \if@height
- \if@width
- \else
- \compute@wfromh
- \fi
- \else
- \if@width
- \compute@hfromw
- \else
- \edef\@p@sheight{\@bbh}
- \edef\@p@swidth{\@bbw}
- \fi
- \fi
-}
-\def\compute@resv{
- \if@rheight \else \edef\@p@srheight{\@p@sheight} \fi
- \if@rwidth \else \edef\@p@srwidth{\@p@swidth} \fi
-}
-%
-% Compute any missing values
-\def\compute@sizes{
- \compute@bb
- \compute@handw
- \compute@resv
-}
-%
-% \psfig
-% usage : \psfig{file=, height=, width=, bbllx=, bblly=, bburx=, bbury=,
-% rheight=, rwidth=, clip=}
-%
-% "clip=" is a switch and takes no value, but the `=' must be present.
-\def\psfig#1{\vbox {
- % do a zero width hard space so that a single
- % \psfig in a centering enviornment will behave nicely
- %{\setbox0=\hbox{\ }\ \hskip-\wd0}
- %
- \ps@init@parms
- \parse@ps@parms{#1}
- \compute@sizes
- %
- \ifnum\@p@scost<\@psdraft{
- \if@verbose{
- \typeout{psfig: including \@p@sfile \space }
- }\fi
- %
- \special{ pstext="\@p@swidth \space
- \@p@sheight \space
- \@p@sbbllx \space \@p@sbblly \space
- \@p@sbburx \space
- \@p@sbbury \space startTexFig" \space}
- \if@clip{
- \if@verbose{
- \typeout{(clip)}
- }\fi
- \special{ pstext="doclip \space"}
- }\fi
- \if@prologfile
- \special{psfile=\@prologfileval \space } \fi
- \special{psfile=\@p@sfile \space }
- \if@postlogfile
- \special{psfile=\@postlogfileval \space } \fi
- \special{pstext=endTexFig \space }
- % Create the vbox to reserve the space for the figure
- \vbox to \@p@srheight true sp{
- \hbox to \@p@srwidth true sp{
- \hss
- }
- \vss
- }
- }\else{
- % draft figure, just reserve the space and print the
- % path name.
- \vbox to \@p@srheight true sp{
- \vss
- \hbox to \@p@srwidth true sp{
- \hss
- \if@verbose{
- \@p@sfile
- }\fi
- \hss
- }
- \vss
- }
- }\fi
-}}
-\def\psglobal{\typeout{psfig: PSGLOBAL is OBSOLETE; use psprint -m instead}}
-\catcode`\@=12\relax
-
diff --git a/lapack-netlib/INSTALL/dlamch.f b/lapack-netlib/INSTALL/dlamch.f
index eb307e5e1..25c2c8e6e 100644
--- a/lapack-netlib/INSTALL/dlamch.f
+++ b/lapack-netlib/INSTALL/dlamch.f
@@ -72,6 +72,10 @@
CHARACTER CMACH
* ..
*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B
+* ..
+*
* =====================================================================
*
* .. Parameters ..
diff --git a/lapack-netlib/INSTALL/ilaver.f b/lapack-netlib/INSTALL/ilaver.f
index a00cbbccf..c33fef7c5 100644
--- a/lapack-netlib/INSTALL/ilaver.f
+++ b/lapack-netlib/INSTALL/ilaver.f
@@ -41,14 +41,14 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
@@ -58,8 +58,8 @@
INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
* =====================================================================
VERS_MAJOR = 3
- VERS_MINOR = 4
- VERS_PATCH = 2
+ VERS_MINOR = 5
+ VERS_PATCH = 0
* =====================================================================
*
RETURN
diff --git a/lapack-netlib/INSTALL/make.inc.ALPHA b/lapack-netlib/INSTALL/make.inc.ALPHA
index f38aa8934..0a3f468ce 100644
--- a/lapack-netlib/INSTALL/make.inc.ALPHA
+++ b/lapack-netlib/INSTALL/make.inc.ALPHA
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.HPPA b/lapack-netlib/INSTALL/make.inc.HPPA
index aee46d068..396d62275 100644
--- a/lapack-netlib/INSTALL/make.inc.HPPA
+++ b/lapack-netlib/INSTALL/make.inc.HPPA
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.IRIX64 b/lapack-netlib/INSTALL/make.inc.IRIX64
index 00d7a20fc..20925374a 100644
--- a/lapack-netlib/INSTALL/make.inc.IRIX64
+++ b/lapack-netlib/INSTALL/make.inc.IRIX64
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /sbin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.O2K b/lapack-netlib/INSTALL/make.inc.O2K
index 48a45a713..c3ab2bdca 100644
--- a/lapack-netlib/INSTALL/make.inc.O2K
+++ b/lapack-netlib/INSTALL/make.inc.O2K
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /sbin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.SGI5 b/lapack-netlib/INSTALL/make.inc.SGI5
index d57c1e287..def1b8099 100644
--- a/lapack-netlib/INSTALL/make.inc.SGI5
+++ b/lapack-netlib/INSTALL/make.inc.SGI5
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /sbin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.SUN4 b/lapack-netlib/INSTALL/make.inc.SUN4
index d8513d393..b2c0239bb 100644
--- a/lapack-netlib/INSTALL/make.inc.SUN4
+++ b/lapack-netlib/INSTALL/make.inc.SUN4
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.SUN4SOL2 b/lapack-netlib/INSTALL/make.inc.SUN4SOL2
index 9b690c375..3302a38d8 100644
--- a/lapack-netlib/INSTALL/make.inc.SUN4SOL2
+++ b/lapack-netlib/INSTALL/make.inc.SUN4SOL2
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.XLF b/lapack-netlib/INSTALL/make.inc.XLF
index 903dc2fe2..5b854b659 100644
--- a/lapack-netlib/INSTALL/make.inc.XLF
+++ b/lapack-netlib/INSTALL/make.inc.XLF
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.gfortran b/lapack-netlib/INSTALL/make.inc.gfortran
index 94b5d178c..a9e5c34d5 100644
--- a/lapack-netlib/INSTALL/make.inc.gfortran
+++ b/lapack-netlib/INSTALL/make.inc.gfortran
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
@@ -13,9 +13,9 @@ SHELL = /bin/sh
# desired load options for your machine.
#
FORTRAN = gfortran
-OPTS = -O2
+OPTS = -O2 -frecursive
DRVOPTS = $(OPTS)
-NOOPT = -O0
+NOOPT = -O0 -frecursive
LOADER = gfortran
LOADOPTS =
#
diff --git a/lapack-netlib/INSTALL/make.inc.gfortran_debug b/lapack-netlib/INSTALL/make.inc.gfortran_debug
index edf812a1a..79ffddf14 100644
--- a/lapack-netlib/INSTALL/make.inc.gfortran_debug
+++ b/lapack-netlib/INSTALL/make.inc.gfortran_debug
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
@@ -12,10 +12,10 @@ SHELL = /bin/sh
# selected. Define LOADER and LOADOPTS to refer to the loader
# and desired load options for your machine.
#
-FORTRAN = gfortran -fimplicit-none -g
+FORTRAN = gfortran -fimplicit-none -g -frecursive
OPTS =
DRVOPTS = $(OPTS)
-NOOPT = -g -O0
+NOOPT = -g -O0 -frecursive
LOADER = gfortran -g
LOADOPTS =
#
diff --git a/lapack-netlib/INSTALL/make.inc.ifort b/lapack-netlib/INSTALL/make.inc.ifort
index 9d476d859..962689f59 100644
--- a/lapack-netlib/INSTALL/make.inc.ifort
+++ b/lapack-netlib/INSTALL/make.inc.ifort
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.pgf95 b/lapack-netlib/INSTALL/make.inc.pgf95
index bdf371ca1..95ba49f36 100644
--- a/lapack-netlib/INSTALL/make.inc.pgf95
+++ b/lapack-netlib/INSTALL/make.inc.pgf95
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/INSTALL/make.inc.pghpf b/lapack-netlib/INSTALL/make.inc.pghpf
index 08c5cceef..6c8b48633 100644
--- a/lapack-netlib/INSTALL/make.inc.pghpf
+++ b/lapack-netlib/INSTALL/make.inc.pghpf
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.1 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
diff --git a/lapack-netlib/README b/lapack-netlib/README
index c236f6adf..f3fbab1f6 100644
--- a/lapack-netlib/README
+++ b/lapack-netlib/README
@@ -20,6 +20,7 @@ VERSION 3.3.1 : April 2011
VERSION 3.4.0 : November 2011
VERSION 3.4.1 : April 2012
VERSION 3.4.2 : September 2012
+VERSION 3.5.0 : November 2013
LAPACK is a library of Fortran 90 with subroutines for solving
the most commonly occurring problems in numerical linear algebra.
@@ -40,8 +41,8 @@ very much on the efficiency of the BLAS.
=================
LAPACK INSTALLATION:
- - LAPACK can be installed with make. Configuration haev to be set in the
- make.inc file. A make.inc.example for a Linux mahcine running GNU compilers
+ - LAPACK can be installed with make. Configuration have to be set in the
+ make.inc file. A make.inc.example for a Linux machine running GNU compilers
is given in the main directory. Some specific make.inc are also available in
the INSTALL directory
- LAPACK includes also the CMAKE build. You will need to have CMAKE installed
diff --git a/lapack-netlib/SRC/CMakeLists.txt b/lapack-netlib/SRC/CMakeLists.txt
index 0150ccc0f..d618d6e01 100644
--- a/lapack-netlib/SRC/CMakeLists.txt
+++ b/lapack-netlib/SRC/CMakeLists.txt
@@ -113,7 +113,7 @@ set(SLASRC
slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f
slarf.f slarfb.f slarfg.f slarfgp.f slarft.f slarfx.f slargv.f
slarrv.f slartv.f
- slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f
+ slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f slasyf_rook.f
slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f slatzm.f
slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f
sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f
@@ -134,6 +134,8 @@ set(SLASRC
ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f
ssytd2.f ssytf2.f ssytrd.f ssytrf.f ssytri.f ssytri2.f ssytri2x.f
ssyswapr.f ssytrs.f ssytrs2.f ssyconv.f
+ ssytf2_rook.f ssytrf_rook.f ssytrs_rook.f
+ ssytri_rook.f ssycon_rook.f ssysv_rook.f
stbcon.f
stbrfs.f stbtrs.f stgevc.f stgex2.f stgexc.f stgsen.f
stgsja.f stgsna.f stgsy2.f stgsyl.f stpcon.f stprfs.f stptri.f
@@ -144,7 +146,8 @@ set(SLASRC
stfttr.f stpttf.f stpttr.f strttf.f strttp.f
sgejsv.f sgesvj.f sgsvj0.f sgsvj1.f
sgeequb.f ssyequb.f spoequb.f sgbequb.f
- sbbcsd.f slapmr.f sorbdb.f sorcsd.f
+ sbbcsd.f slapmr.f sorbdb.f sorbdb1.f sorbdb2.f sorbdb3.f sorbdb4.f
+ sorbdb5.f sorbdb6.f sorcsd.f sorcsd2by1.f
sgeqrt.f sgeqrt2.f sgeqrt3.f sgemqrt.f
stpqrt.f stpqrt2.f stpmqrt.f stprfb.f
)
@@ -176,15 +179,17 @@ set(CLASRC
checon.f cheev.f cheevd.f cheevr.f cheevx.f chegs2.f chegst.f
chegv.f chegvd.f chegvx.f cherfs.f chesv.f chesvx.f chetd2.f
chetf2.f chetrd.f
- chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f
- chetrs.f chetrs2.f chgeqz.f chpcon.f chpev.f chpevd.f
+ chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f
+ chetrs.f chetrs2.f
+ chetf2_rook.f chetrf_rook.f chetri_rook.f chetrs_rook.f checon_rook.f chesv_rook.f
+ chgeqz.f chpcon.f chpev.f chpevd.f
chpevx.f chpgst.f chpgv.f chpgvd.f chpgvx.f chprfs.f chpsv.f
chpsvx.f
chptrd.f chptrf.f chptri.f chptrs.f chsein.f chseqr.f clabrd.f
clacgv.f clacon.f clacn2.f clacp2.f clacpy.f clacrm.f clacrt.f cladiv.f
claed0.f claed7.f claed8.f
claein.f claesy.f claev2.f clags2.f clagtm.f
- clahef.f clahqr.f
+ clahef.f clahef_rook.f clahqr.f
clahrd.f clahr2.f claic1.f clals0.f clalsa.f clalsd.f clangb.f clange.f clangt.f
clanhb.f clanhe.f
clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f
@@ -195,7 +200,7 @@ set(CLASRC
clarf.f clarfb.f clarfg.f clarfgp.f clarft.f
clarfx.f clargv.f clarnv.f clarrv.f clartg.f clartv.f
clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f
- claswp.f clasyf.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f
+ claswp.f clasyf.f clasyf_rook.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f
clatzm.f clauu2.f clauum.f cpbcon.f cpbequ.f cpbrfs.f cpbstf.f cpbsv.f
cpbsvx.f cpbtf2.f cpbtrf.f cpbtrs.f cpocon.f cpoequ.f cporfs.f
cposv.f cposvx.f cpotf2.f cpotrf.f cpotri.f cpotrs.f cpstrf.f cpstf2.f
@@ -207,6 +212,8 @@ set(CLASRC
csyr.f csyrfs.f csysv.f csysvx.f csytf2.f csytrf.f csytri.f
csytri2.f csytri2x.f csyswapr.f
csytrs.f csytrs2.f csyconv.f
+ csytf2_rook.f csytrf_rook.f csytrs_rook.f
+ csytri_rook.f csycon_rook.f csysv_rook.f
ctbcon.f ctbrfs.f ctbtrs.f ctgevc.f ctgex2.f
ctgexc.f ctgsen.f ctgsja.f ctgsna.f ctgsy2.f ctgsyl.f ctpcon.f
ctprfs.f ctptri.f
@@ -219,7 +226,8 @@ set(CLASRC
chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f
ctfttr.f ctpttf.f ctpttr.f ctrttf.f ctrttp.f
cgeequb.f cgbequb.f csyequb.f cpoequb.f cheequb.f
- cbbcsd.f clapmr.f cunbdb.f cuncsd.f
+ cbbcsd.f clapmr.f cunbdb.f cunbdb1.f cunbdb2.f cunbdb3.f cunbdb4.f
+ cunbdb5.f cunbdb6.f cuncsd.f cuncsd2by1.f
cgeqrt.f cgeqrt2.f cgeqrt3.f cgemqrt.f
ctpqrt.f ctpqrt2.f ctpmqrt.f ctprfb.f)
@@ -261,7 +269,7 @@ set(DLASRC
dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f
dlarf.f dlarfb.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlargv.f
dlarrv.f dlartv.f
- dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f
+ dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f
dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f dlatzm.f dlauu2.f
dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f
dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f
@@ -283,6 +291,8 @@ set(DLASRC
dsysv.f dsysvx.f
dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f
dsytri2.f dsytri2x.f dsyswapr.f dsyconv.f
+ dsytf2_rook.f dsytrf_rook.f dsytrs_rook.f
+ dsytri_rook.f dsycon_rook.f dsysv_rook.f
dtbcon.f
dtbrfs.f dtbtrs.f dtgevc.f dtgex2.f dtgexc.f dtgsen.f
dtgsja.f dtgsna.f dtgsy2.f dtgsyl.f dtpcon.f dtprfs.f dtptri.f
@@ -294,7 +304,8 @@ set(DLASRC
dtfttr.f dtpttf.f dtpttr.f dtrttf.f dtrttp.f
dgejsv.f dgesvj.f dgsvj0.f dgsvj1.f
dgeequb.f dsyequb.f dpoequb.f dgbequb.f
- dbbcsd.f dlapmr.f dorbdb.f dorcsd.f
+ dbbcsd.f dlapmr.f dorbdb.f dorbdb1.f dorbdb2.f dorbdb3.f dorbdb4.f
+ dorbdb5.f dorbdb6.f dorcsd.f dorcsd2by1.f
dgeqrt.f dgeqrt2.f dgeqrt3.f dgemqrt.f
dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f )
@@ -324,14 +335,16 @@ set(ZLASRC
zhegv.f zhegvd.f zhegvx.f zherfs.f zhesv.f zhesvx.f zhetd2.f
zhetf2.f zhetrd.f
zhetrf.f zhetri.f zhetri2.f zhetri2x.f zheswapr.f
- zhetrs.f zhetrs2.f zhgeqz.f zhpcon.f zhpev.f zhpevd.f
+ zhetrs.f zhetrs2.f
+ zhetf2_rook.f zhetrf_rook.f zhetri_rook.f zhetrs_rook.f zhecon_rook.f zhesv_rook.f
+ zhgeqz.f zhpcon.f zhpev.f zhpevd.f
zhpevx.f zhpgst.f zhpgv.f zhpgvd.f zhpgvx.f zhprfs.f zhpsv.f
zhpsvx.f
zhptrd.f zhptrf.f zhptri.f zhptrs.f zhsein.f zhseqr.f zlabrd.f
zlacgv.f zlacon.f zlacn2.f zlacp2.f zlacpy.f zlacrm.f zlacrt.f zladiv.f
zlaed0.f zlaed7.f zlaed8.f
zlaein.f zlaesy.f zlaev2.f zlags2.f zlagtm.f
- zlahef.f zlahqr.f
+ zlahef.f zlahef_rook.f zlahqr.f
zlahrd.f zlahr2.f zlaic1.f zlals0.f zlalsa.f zlalsd.f zlangb.f zlange.f
zlangt.f zlanhb.f
zlanhe.f
@@ -344,7 +357,7 @@ set(ZLASRC
zlarfg.f zlarfgp.f zlarft.f
zlarfx.f zlargv.f zlarnv.f zlarrv.f zlartg.f zlartv.f
zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f
- zlassq.f zlaswp.f zlasyf.f
+ zlassq.f zlaswp.f zlasyf.f zlasyf_rook.f
zlatbs.f zlatdf.f zlatps.f zlatrd.f zlatrs.f zlatrz.f zlatzm.f zlauu2.f
zlauum.f zpbcon.f zpbequ.f zpbrfs.f zpbstf.f zpbsv.f
zpbsvx.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpoequ.f zporfs.f
@@ -357,6 +370,8 @@ set(ZLASRC
zsyr.f zsyrfs.f zsysv.f zsysvx.f zsytf2.f zsytrf.f zsytri.f
zsytri2.f zsytri2x.f zsyswapr.f
zsytrs.f zsytrs2.f zsyconv.f
+ zsytf2_rook.f zsytrf_rook.f zsytrs_rook.f
+ zsytri_rook.f zsycon_rook.f zsysv_rook.f
ztbcon.f ztbrfs.f ztbtrs.f ztgevc.f ztgex2.f
ztgexc.f ztgsen.f ztgsja.f ztgsna.f ztgsy2.f ztgsyl.f ztpcon.f
ztprfs.f ztptri.f
@@ -371,7 +386,8 @@ set(ZLASRC
zhfrk.f ztfttp.f zlanhf.f zpftrf.f zpftri.f zpftrs.f ztfsm.f ztftri.f
ztfttr.f ztpttf.f ztpttr.f ztrttf.f ztrttp.f
zgeequb.f zgbequb.f zsyequb.f zpoequb.f zheequb.f
- zbbcsd.f zlapmr.f zunbdb.f zuncsd.f
+ zbbcsd.f zlapmr.f zunbdb.f zunbdb1.f zunbdb2.f zunbdb3.f zunbdb4.f
+ zunbdb5.f zunbdb6.f zuncsd.f zuncsd2by1.f
zgeqrt.f zgeqrt2.f zgeqrt3.f zgemqrt.f
ztpqrt.f ztpqrt2.f ztpmqrt.f ztprfb.f)
diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile
index 92dffdd5f..85154280f 100644
--- a/lapack-netlib/SRC/Makefile
+++ b/lapack-netlib/SRC/Makefile
@@ -118,7 +118,7 @@ SLASRC = \
slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
slarf.o slarfb.o slarfg.o slarfgp.o slarft.o slarfx.o slargv.o \
slarrv.o slartv.o \
- slarz.o slarzb.o slarzt.o slasy2.o slasyf.o \
+ slarz.o slarzb.o slarzt.o slasy2.o slasyf.o slasyf_rook.o \
slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o slatzm.o \
sopgtr.o sopmtr.o sorg2l.o sorg2r.o \
sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \
@@ -140,6 +140,8 @@ SLASRC = \
ssygst.o ssygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o ssysvx.o \
ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \
ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o \
+ ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \
+ ssytri_rook.o ssycon_rook.o ssysv_rook.o \
stbcon.o \
stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \
stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \
@@ -150,7 +152,8 @@ SLASRC = \
stfttr.o stpttf.o stpttr.o strttf.o strttp.o \
sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \
sgeequb.o ssyequb.o spoequb.o sgbequb.o \
- sbbcsd.o slapmr.o sorbdb.o sorcsd.o \
+ sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \
+ sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \
sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \
stpqrt.o stpqrt2.o stpmqrt.o stprfb.o
@@ -184,14 +187,16 @@ CLASRC = \
chegv.o chegvd.o chegvx.o cherfs.o chesv.o chesvx.o chetd2.o \
chetf2.o chetrd.o \
chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \
- chetrs.o chetrs2.o chgeqz.o chpcon.o chpev.o chpevd.o \
+ chetrs.o chetrs2.o \
+ chetf2_rook.o chetrf_rook.o chetri_rook.o chetrs_rook.o checon_rook.o chesv_rook.o \
+ chgeqz.o chpcon.o chpev.o chpevd.o \
chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \
chpsvx.o \
chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \
clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \
claed0.o claed7.o claed8.o \
claein.o claesy.o claev2.o clags2.o clagtm.o \
- clahef.o clahqr.o \
+ clahef.o clahef_rook.o clahqr.o \
clahrd.o clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \
clanhb.o clanhe.o \
clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \
@@ -202,7 +207,7 @@ CLASRC = \
clarf.o clarfb.o clarfg.o clarft.o clarfgp.o \
clarfx.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \
clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \
- clasyf.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \
+ clasyf.o clasyf_rook.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \
clatzm.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \
cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \
cposv.o cposvx.o cpotri.o cpstrf.o cpstf2.o \
@@ -214,6 +219,8 @@ CLASRC = \
csycon.o csymv.o \
csyr.o csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o csytri2.o csytri2x.o \
csyswapr.o csytrs.o csytrs2.o csyconv.o \
+ csytf2_rook.o csytrf_rook.o csytrs_rook.o \
+ csytri_rook.o csycon_rook.o csysv_rook.o \
ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \
ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \
ctprfs.o ctptri.o \
@@ -226,7 +233,8 @@ CLASRC = \
chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \
ctfttr.o ctpttf.o ctpttr.o ctrttf.o ctrttp.o \
cgeequb.o cgbequb.o csyequb.o cpoequb.o cheequb.o \
- cbbcsd.o clapmr.o cunbdb.o cuncsd.o \
+ cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \
+ cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \
cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \
ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o
@@ -270,7 +278,7 @@ DLASRC = \
dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
dlarf.o dlarfb.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o \
dlargv.o dlarrv.o dlartv.o \
- dlarz.o dlarzb.o dlarzt.o dlasy2.o dlasyf.o \
+ dlarz.o dlarzb.o dlarzt.o dlasy2.o dlasyf.o dlasyf_rook.o \
dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlatzm.o \
dopgtr.o dopmtr.o dorg2l.o dorg2r.o \
dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \
@@ -293,6 +301,8 @@ DLASRC = \
dsysv.o dsysvx.o \
dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \
dsyswapr.o dsytrs.o dsytrs2.o dsyconv.o \
+ dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \
+ dsytri_rook.o dsycon_rook.o dsysv_rook.o \
dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \
dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \
dtptrs.o \
@@ -303,7 +313,8 @@ DLASRC = \
dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \
dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \
dgeequb.o dsyequb.o dpoequb.o dgbequb.o \
- dbbcsd.o dlapmr.o dorbdb.o dorcsd.o \
+ dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \
+ dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \
dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \
dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o
@@ -335,14 +346,16 @@ ZLASRC = \
zhegv.o zhegvd.o zhegvx.o zherfs.o zhesv.o zhesvx.o zhetd2.o \
zhetf2.o zhetrd.o \
zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \
- zhetrs.o zhetrs2.o zhgeqz.o zhpcon.o zhpev.o zhpevd.o \
+ zhetrs.o zhetrs2.o \
+ zhetf2_rook.o zhetrf_rook.o zhetri_rook.o zhetrs_rook.o zhecon_rook.o zhesv_rook.o \
+ zhgeqz.o zhpcon.o zhpev.o zhpevd.o \
zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \
zhpsvx.o \
zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \
zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \
zlaed0.o zlaed7.o zlaed8.o \
zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \
- zlahef.o zlahqr.o \
+ zlahef.o zlahef_rook.o zlahqr.o \
zlahrd.o zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \
zlangt.o zlanhb.o \
zlanhe.o \
@@ -355,7 +368,7 @@ ZLASRC = \
zlarfg.o zlarft.o zlarfgp.o \
zlarfx.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \
zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \
- zlassq.o zlasyf.o \
+ zlassq.o zlasyf.o zlasyf_rook.o \
zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlatzm.o zlauu2.o \
zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \
zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \
@@ -368,6 +381,8 @@ ZLASRC = \
zsycon.o zsymv.o \
zsyr.o zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o zsytri2.o zsytri2x.o \
zsyswapr.o zsytrs.o zsytrs2.o zsyconv.o \
+ zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o \
+ zsytri_rook.o zsycon_rook.o zsysv_rook.o \
ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \
ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \
ztprfs.o ztptri.o \
@@ -382,7 +397,8 @@ ZLASRC = \
zhfrk.o ztfttp.o zlanhf.o zpftrf.o zpftri.o zpftrs.o ztfsm.o ztftri.o \
ztfttr.o ztpttf.o ztpttr.o ztrttf.o ztrttp.o \
zgeequb.o zgbequb.o zsyequb.o zpoequb.o zheequb.o \
- zbbcsd.o zlapmr.o zunbdb.o zuncsd.o \
+ zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \
+ zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \
zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \
ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o
diff --git a/lapack-netlib/SRC/cbbcsd.f b/lapack-netlib/SRC/cbbcsd.f
index d60f532c1..2d619cde1 100644
--- a/lapack-netlib/SRC/cbbcsd.f
+++ b/lapack-netlib/SRC/cbbcsd.f
@@ -322,7 +322,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -332,10 +332,10 @@
$ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E,
$ B22D, B22E, RWORK, LRWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
@@ -477,7 +477,10 @@
* Initial deflation
*
IMAX = Q
- DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) )
+ DO WHILE( IMAX .GT. 1 )
+ IF( PHI(IMAX-1) .NE. ZERO ) THEN
+ EXIT
+ END IF
IMAX = IMAX - 1
END DO
IMIN = IMAX - 1
diff --git a/lapack-netlib/SRC/cgebal.f b/lapack-netlib/SRC/cgebal.f
index 4bb5a2f0b..bcd9f516f 100644
--- a/lapack-netlib/SRC/cgebal.f
+++ b/lapack-netlib/SRC/cgebal.f
@@ -122,7 +122,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexGEcomputational
*
@@ -161,10 +161,10 @@
* =====================================================================
SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
@@ -195,8 +195,8 @@
* .. External Functions ..
LOGICAL SISNAN, LSAME
INTEGER ICAMAX
- REAL SLAMCH
- EXTERNAL SISNAN, LSAME, ICAMAX, SLAMCH
+ REAL SLAMCH, SCNRM2
+ EXTERNAL SISNAN, LSAME, ICAMAX, SLAMCH, SCNRM2
* ..
* .. External Subroutines ..
EXTERNAL CSSCAL, CSWAP, XERBLA
@@ -325,15 +325,9 @@
NOCONV = .FALSE.
*
DO 200 I = K, L
- C = ZERO
- R = ZERO
-*
- DO 150 J = K, L
- IF( J.EQ.I )
- $ GO TO 150
- C = C + CABS1( A( J, I ) )
- R = R + CABS1( A( I, J ) )
- 150 CONTINUE
+*
+ C = SCNRM2( L-K+1, A( K, I ), 1 )
+ R = SCNRM2( L-K+1, A( I , K ), LDA )
ICA = ICAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = ICAMAX( N-K+1, A( I, K ), LDA )
diff --git a/lapack-netlib/SRC/cgemqrt.f b/lapack-netlib/SRC/cgemqrt.f
index 76f345cca..ae6f8c7a6 100644
--- a/lapack-netlib/SRC/cgemqrt.f
+++ b/lapack-netlib/SRC/cgemqrt.f
@@ -160,7 +160,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexGEcomputational
*
@@ -168,10 +168,10 @@
SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -225,7 +225,7 @@
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN
INFO = -5
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN
INFO = -6
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
INFO = -8
diff --git a/lapack-netlib/SRC/cgeqrt.f b/lapack-netlib/SRC/cgeqrt.f
index e1ee0011a..a84916820 100644
--- a/lapack-netlib/SRC/cgeqrt.f
+++ b/lapack-netlib/SRC/cgeqrt.f
@@ -108,7 +108,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexGEcomputational
*
@@ -141,10 +141,10 @@
* =====================================================================
SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDT, M, N, NB
@@ -173,7 +173,7 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN
+ ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
diff --git a/lapack-netlib/SRC/cgetc2.f b/lapack-netlib/SRC/cgetc2.f
index e67ea9694..fac6b56820 100644
--- a/lapack-netlib/SRC/cgetc2.f
+++ b/lapack-netlib/SRC/cgetc2.f
@@ -98,7 +98,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexGEauxiliary
*
@@ -111,10 +111,10 @@
* =====================================================================
SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
@@ -203,6 +203,12 @@
INFO = N
A( N, N ) = CMPLX( SMIN, ZERO )
END IF
+*
+* Set last pivots to N
+*
+ IPIV( N ) = N
+ JPIV( N ) = N
+*
RETURN
*
* End of CGETC2
diff --git a/lapack-netlib/SRC/checon_rook.f b/lapack-netlib/SRC/checon_rook.f
new file mode 100644
index 000000000..b986387b6
--- /dev/null
+++ b/lapack-netlib/SRC/checon_rook.f
@@ -0,0 +1,253 @@
+*> \brief \b CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHECON_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHECON_ROOK estimates the reciprocal of the condition number of a complex
+*> Hermitian matrix A using the factorization A = U*D*U**H or
+*> A = L*D*L**H computed by CHETRF_ROOK.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**H;
+*> = 'L': Lower triangular, form is A = L*D*L**H.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is REAL
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is REAL
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (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
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHETRS_ROOK, CLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHECON_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
+*
+ CALL CHETRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of CHECON_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/chesv_rook.f b/lapack-netlib/SRC/chesv_rook.f
new file mode 100644
index 000000000..76a6f5e3c
--- /dev/null
+++ b/lapack-netlib/SRC/chesv_rook.f
@@ -0,0 +1,295 @@
+*> \brief \b CHESV_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using the bounded Bunch-Kaufman ("rook") diagonal pivoting method
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHESV_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+* LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHESV_ROOK computes the solution to a complex system of linear equations
+*> A * X = B,
+*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
+*> matrices.
+*>
+*> The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used
+*> to factor A as
+*> A = U * D * U**T, if UPLO = 'U', or
+*> A = L * D * L**T, if UPLO = 'L',
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is Hermitian and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> CHETRF_ROOK is called to compute the factorization of a complex
+*> Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method.
+*>
+*> The factored form of A is then used to solve the system
+*> of equations A * X = B by calling CHETRS_ROOK (uses BLAS 2).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order of the
+*> matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, if INFO = 0, the block diagonal matrix D and the
+*> multipliers used to obtain the factor U or L from the
+*> factorization A = U*D*U**H or A = L*D*L**H as computed by
+*> CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \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 length of WORK. LWORK >= 1, and for best performance
+*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+*> CHETRF_ROOK.
+*> for LWORK < N, TRS will be done with Level BLAS 2
+*> for LWORK >= N, TRS will be done with Level BLAS 3
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, so the solution could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexHEsolve
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+*
+* =====================================================================
+ SUBROUTINE CHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CHETRF_ROOK, CHETRS_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'CHETRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHESV_ROOK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**H or A = L*D*L**H.
+*
+ CALL CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+* Solve with TRS ( Use Level BLAS 2)
+*
+ CALL CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of CHESV_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/chetf2.f b/lapack-netlib/SRC/chetf2.f
index 101bc1ee7..6f7fa3214 100644
--- a/lapack-netlib/SRC/chetf2.f
+++ b/lapack-netlib/SRC/chetf2.f
@@ -1,4 +1,4 @@
-*> \brief \b CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm).
+*> \brief \b CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm calling Level 2 BLAS).
*
* =========== DOCUMENTATION ===========
*
@@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexHEcomputational
*
@@ -177,10 +186,10 @@
* =====================================================================
SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -268,7 +277,8 @@
ABSAKK = ABS( REAL( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, A( 1, K ), 1 )
@@ -279,7 +289,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -450,7 +461,8 @@
ABSAKK = ABS( REAL( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
@@ -461,7 +473,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is zero or underflow, contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
diff --git a/lapack-netlib/SRC/chetf2_rook.f b/lapack-netlib/SRC/chetf2_rook.f
new file mode 100644
index 000000000..ccd6a7f84
--- /dev/null
+++ b/lapack-netlib/SRC/chetf2_rook.f
@@ -0,0 +1,910 @@
+*> \brief \b CHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETF2_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHETF2_ROOK computes the factorization of a complex Hermitian matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
+*>
+*> A = U*D*U**H or A = L*D*L**H
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, U**H is the conjugate transpose of U, and D is
+*> Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**H, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**H, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * )
+* ..
+*
+* ======================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE, UPPER
+ INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP,
+ $ P
+ REAL ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, STEMP,
+ $ ROWMAX, TT, SFMIN
+ COMPLEX D12, D21, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH, SLAPY2
+ EXTERNAL LSAME, ICAMAX, SLAMCH, SLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CSSCAL, CHER, CSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL, SQRT
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETF2_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**H using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( A( K, K ) )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the leading submatrix A(1:k,1:k)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.GT.1 )
+ $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 14 J = P + 1, K - 1
+ T = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( P, J ) )
+ A( P, J ) = T
+ 14 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = CONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( K, K ) )
+ A( K, K ) = REAL( A( P, P ) )
+ A( P, P ) = R1
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the leading submatrix A(1:k,1:k)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 15 J = KP + 1, KK - 1
+ T = CONJG( A( J, KK ) )
+ A( J, KK ) = CONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 15 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = CONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( KK, KK ) )
+ A( KK, KK ) = REAL( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+* (5) Swap row elements
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K-1, K-1 ) = REAL( A( K-1, K-1 ) )
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / REAL( A( K, K ) )
+ CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL CSSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = REAL( A( K, K ) )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+* D = |A12|
+ D = SLAPY2( REAL( A( K-1, K ) ),
+ $ AIMAG( A( K-1, K ) ) )
+ D11 = A( K, K ) / D
+ D22 = A( K-1, K-1 ) / D
+ D12 = A( K-1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )*
+ $ A( J, K ) )
+ WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) )
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2)
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*CONJG( WK ) -
+ $ ( A( I, K-1 ) / D )*CONJG( WKM1 )
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K-1 ) = WKM1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO )
+*
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**H using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( A( K, K ) )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 42
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the trailing submatrix A(k:n,k:n)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.LT.N )
+ $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 44 J = K + 1, P - 1
+ T = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( P, J ) )
+ A( P, J ) = T
+ 44 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = CONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( K, K ) )
+ A( K, K ) = REAL( A( P, P ) )
+ A( P, P ) = R1
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the trailing submatrix A(k:n,k:n)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 45 J = KK + 1, KP - 1
+ T = CONJG( A( J, KK ) )
+ A( J, KK ) = CONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 45 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = CONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( KK, KK ) )
+ A( KK, KK ) = REAL( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+* (5) Swap row elements
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K+1, K+1 ) = REAL( A( K+1, K+1 ) )
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of A now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+* Handle division by a small number
+*
+ IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / REAL( A( K, K ) )
+ CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL CSSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = REAL( A( K, K ) )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+* D = |A21|
+ D = SLAPY2( REAL( A( K+1, K ) ),
+ $ AIMAG( A( K+1, K ) ) )
+ D11 = REAL( A( K+1, K+1 ) ) / D
+ D22 = REAL( A( K, K ) ) / D
+ D21 = A( K+1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) )
+ WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )*
+ $ A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*CONJG( WK ) -
+ $ ( A( I, K+1 ) / D )*CONJG( WKP1 )
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K+1 ) = WKP1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO )
+*
+ 60 CONTINUE
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of CHETF2_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/chetrf_rook.f b/lapack-netlib/SRC/chetrf_rook.f
new file mode 100644
index 000000000..98c8dbd26
--- /dev/null
+++ b/lapack-netlib/SRC/chetrf_rook.f
@@ -0,0 +1,397 @@
+*> \brief \b CHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETRF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHETRF_ROOK computes the factorization of a comlex Hermitian matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*> The form of the factorization is
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is Hermitian and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLAHEF_ROOK, CHETF2_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'CHETRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETRF_ROOK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'CHETRF_ROOK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by CLAHEF_ROOK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL CLAHEF_ROOK( UPLO, K, NB, KB, A, LDA,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL CHETF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by CLAHEF_ROOK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL CLAHEF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL CHETF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
+ $ IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of CHETRF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/chetri_rook.f b/lapack-netlib/SRC/chetri_rook.f
new file mode 100644
index 000000000..00d99e2a9
--- /dev/null
+++ b/lapack-netlib/SRC/chetri_rook.f
@@ -0,0 +1,516 @@
+*> \brief \b CHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETRI_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix
+*> A using the factorization A = U*D*U**H or A = L*D*L**H computed by
+*> CHETRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**H;
+*> = 'L': Lower triangular, form is A = L*D*L**H.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the block diagonal matrix D and the multipliers
+*> used to obtain the factor U or L as computed by CHETRF_ROOK.
+*>
+*> On exit, if INFO = 0, the (Hermitian) inverse of the original
+*> matrix. If UPLO = 'U', the upper triangular part of the
+*> inverse is formed and the part of A below the diagonal is not
+*> referenced; if UPLO = 'L' the lower triangular part of the
+*> inverse is formed and the part of A above the diagonal is
+*> not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (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, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ COMPLEX CONE, CZERO
+ PARAMETER ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP, KSTEP
+ REAL AK, AKP1, D, T
+ COMPLEX AKKP1, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ COMPLEX CDOTC
+ EXTERNAL LSAME, CDOTC
+* ..
+* .. External Subroutines ..
+ EXTERNAL CCOPY, CHEMV, CSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, CONJG, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETRI_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U**H.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 70
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / REAL( A( K, K ) )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - REAL( CDOTC( K-1, WORK, 1, A( 1,
+ $ K ), 1 ) )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K+1 ) )
+ AK = REAL( A( K, K ) ) / T
+ AKP1 = REAL( A( K+1, K+1 ) ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - REAL( CDOTC( K-1, WORK, 1, A( 1,
+ $ K ), 1 ) )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ CDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ REAL( CDOTC( K-1, WORK, 1, A( 1, K+1 ),
+ $ 1 ) )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the leading
+* submatrix A(1:k,1:k)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+*
+ DO 40 J = KP + 1, K - 1
+ TEMP = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 40 CONTINUE
+*
+ A( KP, K ) = CONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K+1 with -IPIV(K) and
+* -IPIV(K+1) in the leading submatrix A(k+1:n,k+1:n)
+*
+* (1) Interchange rows and columns K and -IPIV(K)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+*
+ DO 50 J = KP + 1, K - 1
+ TEMP = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 50 CONTINUE
+*
+ A( KP, K ) = CONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+*
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+*
+* (2) Interchange rows and columns K+1 and -IPIV(K+1)
+*
+ K = K + 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+*
+ DO 60 J = KP + 1, K - 1
+ TEMP = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 60 CONTINUE
+*
+ A( KP, K ) = CONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K + 1
+ GO TO 30
+ 70 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L**H.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 80 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 120
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / REAL( A( K, K ) )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+ $ 1, CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - REAL( CDOTC( N-K, WORK, 1,
+ $ A( K+1, K ), 1 ) )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K-1 ) )
+ AK = REAL( A( K-1, K-1 ) ) / T
+ AKP1 = REAL( A( K, K ) ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+ $ 1, CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - REAL( CDOTC( N-K, WORK, 1,
+ $ A( K+1, K ), 1 ) )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ CDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+ $ 1, CZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ REAL( CDOTC( N-K, WORK, 1, A( K+1, K-1 ),
+ $ 1 ) )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the trailing
+* submatrix A(k:n,k:n)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+*
+ DO 90 J = K + 1, KP - 1
+ TEMP = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 90 CONTINUE
+*
+ A( KP, K ) = CONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K-1 with -IPIV(K) and
+* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
+*
+* (1) Interchange rows and columns K and -IPIV(K)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+*
+ DO 100 J = K + 1, KP - 1
+ TEMP = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 100 CONTINUE
+*
+ A( KP, K ) = CONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+*
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+*
+* (2) Interchange rows and columns K-1 and -IPIV(K-1)
+*
+ K = K - 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+*
+ DO 110 J = K + 1, KP - 1
+ TEMP = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 110 CONTINUE
+*
+ A( KP, K ) = CONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K - 1
+ GO TO 80
+ 120 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of CHETRI_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/chetrs_rook.f b/lapack-netlib/SRC/chetrs_rook.f
new file mode 100644
index 000000000..2b0cc6db2
--- /dev/null
+++ b/lapack-netlib/SRC/chetrs_rook.f
@@ -0,0 +1,503 @@
+*> \brief \b CHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETRS_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHETRS_ROOK solves a system of linear equations A*X = B with a complex
+*> Hermitian matrix A using the factorization A = U*D*U**H or
+*> A = L*D*L**H computed by CHETRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**H;
+*> = 'L': Lower triangular, form is A = L*D*L**H.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE
+ PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ REAL S
+ COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMV, CGERU, CLACGV, CSSCAL, CSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC CONJG, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETRS_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U**H.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL CGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ S = REAL( ONE ) / REAL( A( K, K ) )
+ CALL CSSCAL( NRHS, S, B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1)
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ CALL CGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+ CALL CGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / CONJG( AKM1K )
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / CONJG( AKM1K )
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U**H *X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U**H(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+*
+ CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+ CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L**H.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL CGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ S = REAL( ONE ) / REAL( A( K, K ) )
+ CALL CSSCAL( NRHS, S, B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / CONJG( AKM1K )
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / CONJG( AKM1K )
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L**H *X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L**H(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+ $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+ $ B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+ $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+ $ B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+*
+ CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+ CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+ $ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE,
+ $ B( K-1, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of CHETRS_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/chsein.f b/lapack-netlib/SRC/chsein.f
index fa87a7341..b4747b53f 100644
--- a/lapack-netlib/SRC/chsein.f
+++ b/lapack-netlib/SRC/chsein.f
@@ -104,6 +104,7 @@
*> \verbatim
*> H is COMPLEX array, dimension (LDH,N)
*> The upper Hessenberg matrix H.
+*> If a NaN is detected in H, the routine will return with INFO=-6.
*> \endverbatim
*>
*> \param[in] LDH
@@ -225,7 +226,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -244,10 +245,10 @@
$ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL,
$ IFAILR, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
@@ -276,9 +277,9 @@
COMPLEX CDUM, WK
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, SISNAN
REAL CLANHS, SLAMCH
- EXTERNAL LSAME, CLANHS, SLAMCH
+ EXTERNAL LSAME, CLANHS, SLAMCH, SISNAN
* ..
* .. External Subroutines ..
EXTERNAL CLAEIN, XERBLA
@@ -399,7 +400,10 @@
* has not ben computed before.
*
HNORM = CLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, RWORK )
- IF( HNORM.GT.RZERO ) THEN
+ IF( SISNAN( HNORM ) ) THEN
+ INFO = -6
+ RETURN
+ ELSE IF( (HNORM.GT.RZERO) ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
diff --git a/lapack-netlib/SRC/chseqr.f b/lapack-netlib/SRC/chseqr.f
index 7f4f977c7..755ca7f7f 100644
--- a/lapack-netlib/SRC/chseqr.f
+++ b/lapack-netlib/SRC/chseqr.f
@@ -43,7 +43,7 @@
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
-*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
*> \endverbatim
*
* Arguments:
@@ -216,7 +216,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -299,10 +299,10 @@
SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
$ WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
diff --git a/lapack-netlib/SRC/cla_lin_berr.f b/lapack-netlib/SRC/cla_lin_berr.f
index 0bfff7a52..94db81439 100644
--- a/lapack-netlib/SRC/cla_lin_berr.f
+++ b/lapack-netlib/SRC/cla_lin_berr.f
@@ -67,14 +67,14 @@
*>
*> \param[in] RES
*> \verbatim
-*> RES is DOUBLE PRECISION array, dimension (N,NRHS)
+*> RES is REAL array, dimension (N,NRHS)
*> The residual matrix, i.e., the matrix R in the relative backward
*> error formula above.
*> \endverbatim
*>
*> \param[in] AYB
*> \verbatim
-*> AYB is DOUBLE PRECISION array, dimension (N, NRHS)
+*> AYB is REAL array, dimension (N, NRHS)
*> The denominator in the relative backward error formula above, i.e.,
*> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B
*> are from iterative refinement (see cla_gerfsx_extended.f).
@@ -94,17 +94,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
* =====================================================================
SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER N, NZ, NRHS
diff --git a/lapack-netlib/SRC/clahef.f b/lapack-netlib/SRC/clahef.f
index ff269eef4..f51de1867 100644
--- a/lapack-netlib/SRC/clahef.f
+++ b/lapack-netlib/SRC/clahef.f
@@ -1,25 +1,25 @@
-*> \brief \b CLAHEF computes a partial factorization of a complex Hermitian indefinite matrix, using the diagonal pivoting method.
+*> \brief \b CLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download CLAHEF + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download CLAHEF + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
@@ -28,7 +28,7 @@
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), W( LDW, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -110,16 +110,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If UPLO = 'U', only the last KB elements of IPIV are set;
-*> if UPLO = 'L', only the first KB elements are set.
*>
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@@ -145,22 +155,32 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexHEcomputational
*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*> \endverbatim
+*
* =====================================================================
SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -219,17 +239,20 @@
* for use in updating A11 (note that conjg(W) is actually stored)
*
* K is the main loop index, decreasing from N in steps of 1 or 2
-*
-* KW is the column of W which corresponds to column K of A
*
K = N
10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
+*
+ KSTEP = 1
*
* Copy column K of A to column KW of W and update it
*
@@ -240,8 +263,6 @@
$ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
W( K, KW ) = REAL( W( K, KW ) )
END IF
-*
- KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
@@ -249,7 +270,8 @@
ABSAKK = ABS( REAL( W( K, KW ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
@@ -260,13 +282,19 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = REAL( A( K, K ) )
ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@@ -274,6 +302,9 @@
KP = K
ELSE
*
+* BEGIN pivot search along IMAX row
+*
+*
* Copy column IMAX to column KW-1 of W and update it
*
CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
@@ -289,7 +320,8 @@
END IF
*
* JMAX is the column-index of the largest off-diagonal
-* element in row IMAX, and ROWMAX is its absolute value
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine only ROWMAX.
*
JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = CABS1( W( JMAX, KW-1 ) )
@@ -298,11 +330,14 @@
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) )
END IF
*
+* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
+*
+* Case(3)
ELSE IF( ABS( REAL( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@@ -311,9 +346,11 @@
*
KP = IMAX
*
-* copy column KW-1 of W to column KW
+* copy column KW-1 of W to column KW of W
*
CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+* Case(4)
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
@@ -322,27 +359,48 @@
KP = IMAX
KSTEP = 2
END IF
+*
+*
+* END pivot search along IMAX row
+*
END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
KKW = NB + KK - N
*
-* Updated column KP is already stored in column KKW of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
A( KP, KP ) = REAL( A( KK, KK ) )
CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
- CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( KP.GT.1 )
+ $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
-* Interchange rows KK and KP in last KK columns of A and W
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
*
- IF( KK.LT.N )
- $ CALL CSWAP( N-KK, A( KK, KK+1 ), LDA, A( KP, KK+1 ),
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
$ LDA )
CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
@@ -350,40 +408,108 @@
*
IF( KSTEP.EQ.1 ) THEN
*
-* 1-by-1 pivot block D(k): column KW of W now holds
+* 1-by-1 pivot block D(k): column kw of W now holds
*
-* W(k) = U(k)*D(k)
+* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
-* Store U(k) in column k of A
+* (1) Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
- R1 = ONE / REAL( A( K, K ) )
- CALL CSSCAL( K-1, R1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
*
-* Conjugate W(k)
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(4))
+*
+ R1 = ONE / REAL( A( K, K ) )
+ CALL CSSCAL( K-1, R1, A( 1, K ), 1 )
+*
+* (2) Conjugate column W(kw)
+*
+ CALL CLACGV( K-1, W( 1, KW ), 1 )
+ END IF
*
- CALL CLACGV( K-1, W( 1, KW ), 1 )
ELSE
*
-* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
-* hold
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
-* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
+*
+* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored)
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
-* Store U(k) and U(k-1) in columns k and k-1 of A
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( conj(D21)*( D11 ) D21*( -1 ) )
+* ( ( -1 ) ( D22 ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = T/d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0, since in 2x2 pivot case(4)
+* |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / CONJG( D21 )
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( REAL( D11*D22 )-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = CONJG( D21 )*
@@ -397,11 +523,13 @@
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
*
-* Conjugate W(k) and W(k-1)
+* (2) Conjugate columns W(kw) and W(kw-1)
*
CALL CLACGV( K-1, W( 1, KW ), 1 )
CALL CLACGV( K-2, W( 1, KW-1 ), 1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -448,19 +576,27 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
-* in columns k+1:n
+* in of rows in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows J and JP
+* at each step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J + 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
J = J + 1
- END IF
- J = J + 1
- IF( JP.NE.JJ .AND. J.LE.N )
- $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
$ GO TO 60
*
@@ -483,6 +619,8 @@
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
+*
+ KSTEP = 1
*
* Copy column K of A to column K of W and update it
*
@@ -492,8 +630,6 @@
CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
$ W( K, 1 ), LDW, CONE, W( K, K ), 1 )
W( K, K ) = REAL( W( K, K ) )
-*
- KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
@@ -501,7 +637,8 @@
ABSAKK = ABS( REAL( W( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
@@ -512,13 +649,19 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = REAL( A( K, K ) )
ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@@ -526,6 +669,9 @@
KP = K
ELSE
*
+* BEGIN pivot search along IMAX row
+*
+*
* Copy column IMAX to column K+1 of W and update it
*
CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
@@ -540,7 +686,8 @@
W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) )
*
* JMAX is the column-index of the largest off-diagonal
-* element in row IMAX, and ROWMAX is its absolute value
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine only ROWMAX.
*
JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = CABS1( W( JMAX, K+1 ) )
@@ -549,11 +696,14 @@
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) )
END IF
*
+* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
+*
+* Case(3)
ELSE IF( ABS( REAL( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@@ -562,9 +712,11 @@
*
KP = IMAX
*
-* copy column K+1 of W to column K
+* copy column K+1 of W to column K of W
*
CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+* Case(4)
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
@@ -573,15 +725,29 @@
KP = IMAX
KSTEP = 2
END IF
+*
+*
+* END pivot search along IMAX row
+*
END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
-* Updated column KP is already stored in column KK of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
A( KP, KP ) = REAL( A( KK, KK ) )
CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
@@ -590,9 +756,13 @@
IF( KP.LT.N )
$ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
-* Interchange rows KK and KP in first KK columns of A and W
+* Interchange rows KK and KP in first K-1 columns of A
+* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
*
- CALL CSWAP( KK-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ IF( K.GT.1 )
+ $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@@ -600,21 +770,35 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
-* W(k) = L(k)*D(k)
+* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
-* Store L(k) in column k of A
+* (1) Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(4))
+*
R1 = ONE / REAL( A( K, K ) )
CALL CSSCAL( N-K, R1, A( K+1, K ), 1 )
*
-* Conjugate W(k)
+* (2) Conjugate column W(k)
*
CALL CLACGV( N-K, W( K+1, K ), 1 )
END IF
+*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@@ -623,16 +807,69 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
+*
+* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored)
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
-* Store L(k) and L(k+1) in columns k and k+1 of A
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( conj(D21)*( D11 ) D21*( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = T/d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0, since in 2x2 pivot case(4)
+* |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / CONJG( D21 )
T = ONE / ( REAL( D11*D22 )-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
DO 80 J = K + 2, N
A( J, K ) = CONJG( D21 )*
$ ( D11*W( J, K )-W( J, K+1 ) )
@@ -646,11 +883,13 @@
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
*
-* Conjugate W(k) and W(k+1)
+* (2) Conjugate columns W(k) and W(k+1)
*
CALL CLACGV( N-K, W( K+1, K ), 1 )
CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -698,19 +937,27 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
-* in columns 1:k-1
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows J and JP
+* at each step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J - 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
J = J - 1
- END IF
- J = J - 1
- IF( JP.NE.JJ .AND. J.GE.1 )
- $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
$ GO TO 120
*
diff --git a/lapack-netlib/SRC/clahef_rook.f b/lapack-netlib/SRC/clahef_rook.f
new file mode 100644
index 000000000..698df999f
--- /dev/null
+++ b/lapack-netlib/SRC/clahef_rook.f
@@ -0,0 +1,1176 @@
+* \brief \b CLAHEF_ROOK computes a partial factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CLAHEF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CLAHEF_ROOK computes a partial factorization of a complex Hermitian
+*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting
+*> method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L'
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*> Note that U**H denotes the conjugate transpose of U.
+*>
+*> CLAHEF_ROOK is an auxiliary routine called by CHETRF_ROOK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*> On exit, A contains details of the partial factorization.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ COMPLEX CONE
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K,
+ $ KK, KKW, KP, KSTEP, KW, P
+ REAL ABSAKK, ALPHA, COLMAX, STEMP, R1, ROWMAX, T,
+ $ SFMIN
+ COMPLEX D11, D21, D22, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ICAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CCOPY, CSSCAL, CGEMM, CGEMV, CLACGV, CSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, CONJG, AIMAG, MAX, MIN, REAL, SQRT
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11 (note that conjg(W) is actually stored)
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ IF( K.GT.1 )
+ $ CALL CCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
+ W( K, KW ) = REAL( A( K, K ) )
+ IF( K.LT.N ) THEN
+ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+ $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+ W( K, KW ) = REAL( W( K, KW ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( W( K, KW ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( W( K, KW ) )
+ IF( K.GT.1 )
+ $ CALL CCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+* Lop until pivot found
+*
+ DONE = .FALSE.
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ IF( IMAX.GT.1 )
+ $ CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ),
+ $ 1 )
+ W( IMAX, KW-1 ) = REAL( A( IMAX, IMAX ) )
+*
+ CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+ CALL CLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N ) THEN
+ CALL CGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+ W( IMAX, KW-1 ) = REAL( W( IMAX, KW-1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ STEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( W( IMAX,KW-1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+* Interchange rows and columns P and K.
+* Updated column P is already stored in column KW of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K-1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = REAL( A( K, K ) )
+ CALL CCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ CALL CLACGV( K-1-P, A( P, P+1 ), LDA )
+ IF( P.GT.1 )
+ $ CALL CCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in the last K+1 to N columns of A
+* (columns K and K-1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ),
+ $ LDA )
+ CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ),
+ $ LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = REAL( A( KK, KK ) )
+ CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
+ IF( KP.GT.1 )
+ $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+ CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column kw of W now holds
+*
+* W(kw) = U(k)*D(k),
+*
+* where U(k) is the k-th column of U
+*
+* (1) Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = REAL( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL CSSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+ DO 14 II = 1, K-1
+ A( II, K ) = A( II, K ) / T
+ 14 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(kw)
+*
+ CALL CLACGV( K-1, W( 1, KW ), 1 )
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
+*
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored)
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
+*
+ IF( K.GT.2 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K-1, KW )
+ D11 = W( K, KW ) / CONJG( D21 )
+ D22 = W( K-1, KW-1 ) / D21
+ T = ONE / ( REAL( D11*D22 )-ONE )
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D21 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ CONJG( D21 ) )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+*
+* (2) Conjugate columns W(kw) and W(kw-1)
+*
+ CALL CLACGV( K-1, W( 1, KW ), 1 )
+ CALL CLACGV( K-2, W( 1, KW-1 ), 1 )
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+ $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in of rows in columns k+1:n looping backwards from k+1 to n
+*
+ J = K + 1
+ 60 CONTINUE
+*
+* Undo the interchanges (if any) of rows J and JP2
+* (or J and JP2, and J+1 and JP1) at each step J
+*
+ KSTEP = 1
+ JP1 = 1
+* (Here, J is a diagonal index)
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+* (Here, J is a diagonal index)
+ J = J + 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
+ J = J + 1
+ IF( JP2.NE.JJ .AND. J.LE.N )
+ $ CALL CSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
+ JJ = JJ + 1
+ IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.LE.N )
+ $ CALL CSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LT.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22 (note that conjg(W) is actually stored)
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update column K of W
+*
+ W( K, K ) = REAL( A( K, K ) )
+ IF( K.LT.N )
+ $ CALL CCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+ W( K, K ) = REAL( W( K, K ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( W( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( W( K, K ) )
+ IF( K.LT.N )
+ $ CALL CCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column k+1 of W and update it
+*
+ CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL CLACGV( IMAX-K, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = REAL( A( IMAX, IMAX ) )
+*
+ IF( IMAX.LT.N )
+ $ CALL CCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
+ $ W( IMAX+1, K+1 ), 1 )
+*
+ IF( K.GT.1 ) THEN
+ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ STEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( W( IMAX,K+1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+*
+* End pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 72
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* Interchange rows and columns P and K (only for 2-by-2 pivot).
+* Updated column P is already stored in column K of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column KK-1 to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K+1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = REAL( A( K, K ) )
+ CALL CCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ CALL CLACGV( P-K-1, A( P, K+1 ), LDA )
+ IF( P.LT.N )
+ $ CALL CCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+*
+* Interchange rows K and P in first K-1 columns of A
+* (columns K and K+1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = REAL( A( KK, KK ) )
+ CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ CALL CLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
+ IF( KP.LT.N )
+ $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+*
+* Interchange rows KK and KP in first K-1 columns of A
+* (column K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+* (1) Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = REAL( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL CSSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / T
+ 74 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(k)
+*
+ CALL CLACGV( N-K, W( K+1, K ), 1 )
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored.
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / CONJG( D21 )
+ T = ONE / ( REAL( D11*D22 )-ONE )
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ CONJG( D21 ) )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+*
+* (2) Conjugate columns W(k) and W(k+1)
+*
+ CALL CLACGV( N-K, W( K+1, K ), 1 )
+ CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 )
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
+*
+ J = K - 1
+ 120 CONTINUE
+*
+* Undo the interchanges (if any) of rows J and JP2
+* (or J and JP2, and J-1 and JP1) at each step J
+*
+ KSTEP = 1
+ JP1 = 1
+* (Here, J is a diagonal index)
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+* (Here, J is a diagonal index)
+ J = J - 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
+ J = J - 1
+ IF( JP2.NE.JJ .AND. J.GE.1 )
+ $ CALL CSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
+ JJ = JJ -1
+ IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.GE.1 )
+ $ CALL CSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GT.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of CLAHEF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/clarfb.f b/lapack-netlib/SRC/clarfb.f
index ea378f3a1..19d7b81ca 100644
--- a/lapack-netlib/SRC/clarfb.f
+++ b/lapack-netlib/SRC/clarfb.f
@@ -159,7 +159,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date June 2013
*
*> \ingroup complexOTHERauxiliary
*
@@ -195,10 +195,10 @@
SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@@ -217,12 +217,11 @@
* ..
* .. Local Scalars ..
CHARACTER TRANST
- INTEGER I, J, LASTV, LASTC
+ INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
- INTEGER ILACLR, ILACLC
- EXTERNAL LSAME, ILACLR, ILACLC
+ EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM
@@ -255,36 +254,33 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
- LASTC = ILACLC( LASTV, N, C, LDC )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C1**H
*
DO 10 J = 1, K
- CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
- CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL CLACGV( N, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
- CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
* W := W + C2**H *V2
*
- CALL CGEMM( 'Conjugate transpose', 'No transpose',
- $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
- $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
+ CALL CGEMM( 'Conjugate transpose', 'No transpose', N,
+ $ K, M-K, ONE, C( K+1, 1 ), LDC,
+ $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
@@ -293,19 +289,19 @@
* C2 := C2 - V2 * W**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV,
- $ WORK, LDWORK, ONE, C( K+1, 1 ), LDC )
+ $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
+ $ LDWORK, ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 30 J = 1, K
- DO 20 I = 1, LASTC
+ DO 20 I = 1, N
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
@@ -313,58 +309,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
- LASTC = ILACLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
- CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
- CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
- CALL CGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**H
*
- CALL CGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
- $ ONE, C( 1, K+1 ), LDC )
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
+ $ LDV, ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
- DO 50 I = 1, LASTC
+ DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
@@ -379,38 +370,34 @@
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
-* ( C2 )
-*
- LASTC = ILACLC( M, N, C, LDC )
+* ( C2 )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C2**H
*
DO 70 J = 1, K
- CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
- CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL CLACGV( N, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
- CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
-* W := W + C1**H*V1
+* W := W + C1**H * V1
*
- CALL CGEMM( 'Conjugate transpose', 'No transpose',
- $ LASTC, K, M-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL CGEMM( 'Conjugate transpose', 'No transpose', N,
+ $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
+ $ LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
@@ -419,20 +406,20 @@
* C1 := C1 - V1 * W**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
- $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
- $ ONE, C, LDC )
+ $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
+ $ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
+ $ LDWORK )
*
* C2 := C2 - W**H
*
DO 90 J = 1, K
- DO 80 I = 1, LASTC
+ DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ CONJG( WORK( I, J ) )
80 CONTINUE
@@ -441,36 +428,31 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTC = ILACLR( M, N, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
- CALL CCOPY( LASTC, C( 1, N-K+J ), 1,
- $ WORK( 1, J ), 1 )
+ CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
- CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
- CALL CGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, N-K,
- $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
@@ -478,23 +460,22 @@
*
* C1 := C1 - W * V1**H
*
- CALL CGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
+ $ C, LDC )
END IF
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
+ $ LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
- DO 110 I = 1, LASTC
- C( I, N-K+J ) = C( I, N-K+J )
- $ - WORK( I, J )
+ DO 110 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
@@ -511,59 +492,56 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
- LASTC = ILACLC( LASTV, N, C, LDC )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C1**H
*
DO 130 J = 1, K
- CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
- CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL CLACGV( N, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
-* W := W + C2**H*V2**H
+* W := W + C2**H * V2**H
*
CALL CGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', LASTC, K, LASTV-K,
- $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
- $ ONE, WORK, LDWORK )
+ $ 'Conjugate transpose', N, K, M-K, ONE,
+ $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+ $ WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
- IF( LASTV.GT.K ) THEN
+ IF( M.GT.K ) THEN
*
* C2 := C2 - V2**H * W**H
*
CALL CGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', LASTV-K, LASTC, K,
- $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
- $ ONE, C( K+1, 1 ), LDC )
+ $ 'Conjugate transpose', M-K, N, K, -ONE,
+ $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
- CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 150 J = 1, K
- DO 140 I = 1, LASTC
+ DO 140 I = 1, N
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
@@ -571,57 +549,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
- LASTC = ILACLR( M, LASTV, C, LDC )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
- CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2**H
*
- CALL CGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
- $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ K, N-K, ONE, C( 1, K+1 ), LDC,
+ $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
- CALL CGEMM( 'No transpose', 'No transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
- $ ONE, C( 1, K+1 ), LDC )
+ CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
- CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
- DO 170 I = 1, LASTC
+ DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
@@ -637,37 +611,34 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
-*
- LASTC = ILACLC( M, N, C, LDC )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C2**H
*
DO 190 J = 1, K
- CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
- CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL CLACGV( N, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
+ $ LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1**H
*
CALL CGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', LASTC, K, M-K,
- $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ $ 'Conjugate transpose', N, K, M-K, ONE, C,
+ $ LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
@@ -676,20 +647,19 @@
* C1 := C1 - V1**H * W**H
*
CALL CGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', M-K, LASTC, K,
- $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+ $ 'Conjugate transpose', M-K, N, K, -ONE, V,
+ $ LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 210 J = 1, K
- DO 200 I = 1, LASTC
+ DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ CONJG( WORK( I, J ) )
200 CONTINUE
@@ -698,36 +668,33 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTC = ILACLR( M, N, C, LDC )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
- CALL CCOPY( LASTC, C( 1, N-K+J ), 1,
- $ WORK( 1, J ), 1 )
+ CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
+ $ LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**H
*
- CALL CGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE,
- $ WORK, LDWORK )
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
+ $ LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
@@ -735,21 +702,19 @@
*
* C1 := C1 - W * V1
*
- CALL CGEMM( 'No transpose', 'No transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
- DO 230 I = 1, LASTC
+ DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
diff --git a/lapack-netlib/SRC/clartg.f b/lapack-netlib/SRC/clartg.f
index a720f1d0b..cfff122a1 100644
--- a/lapack-netlib/SRC/clartg.f
+++ b/lapack-netlib/SRC/clartg.f
@@ -85,7 +85,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexOTHERauxiliary
*
@@ -103,10 +103,10 @@
* =====================================================================
SUBROUTINE CLARTG( F, G, CS, SN, R )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
REAL CS
@@ -130,7 +130,8 @@
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
- EXTERNAL SLAMCH, SLAPY2
+ LOGICAL SISNAN
+ EXTERNAL SLAMCH, SLAPY2, SISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, LOG, MAX, REAL,
@@ -139,26 +140,17 @@
* .. Statement Functions ..
REAL ABS1, ABSSQ
* ..
-* .. Save statement ..
-* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
-* ..
-* .. Data statements ..
-* DATA FIRST / .TRUE. /
-* ..
* .. Statement Function definitions ..
ABS1( FF ) = MAX( ABS( REAL( FF ) ), ABS( AIMAG( FF ) ) )
ABSSQ( FF ) = REAL( FF )**2 + AIMAG( FF )**2
* ..
* .. Executable Statements ..
*
-* IF( FIRST ) THEN
- SAFMIN = SLAMCH( 'S' )
- EPS = SLAMCH( 'E' )
- SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
- $ LOG( SLAMCH( 'B' ) ) / TWO )
- SAFMX2 = ONE / SAFMN2
-* FIRST = .FALSE.
-* END IF
+ SAFMIN = SLAMCH( 'S' )
+ EPS = SLAMCH( 'E' )
+ SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+ $ LOG( SLAMCH( 'B' ) ) / TWO )
+ SAFMX2 = ONE / SAFMN2
SCALE = MAX( ABS1( F ), ABS1( G ) )
FS = F
GS = G
@@ -172,7 +164,7 @@
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
ELSE IF( SCALE.LE.SAFMN2 ) THEN
- IF( G.EQ.CZERO ) THEN
+ IF( G.EQ.CZERO.OR.SISNAN( ABS( G ) ) ) THEN
CS = ONE
SN = CZERO
R = F
diff --git a/lapack-netlib/SRC/clasyf.f b/lapack-netlib/SRC/clasyf.f
index 87d911748..ade36f9e2 100644
--- a/lapack-netlib/SRC/clasyf.f
+++ b/lapack-netlib/SRC/clasyf.f
@@ -1,25 +1,25 @@
-*> \brief \b CLASYF computes a partial factorization of a complex symmetric matrix, using the diagonal pivoting method.
+*> \brief \b CLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download CLASYF + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download CLASYF + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
@@ -28,7 +28,7 @@
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), W( LDW, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -110,16 +110,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If UPLO = 'U', only the last KB elements of IPIV are set;
-*> if UPLO = 'L', only the first KB elements are set.
*>
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@@ -145,22 +155,32 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexSYcomputational
*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*> \endverbatim
+*
* =====================================================================
SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -246,7 +266,8 @@
ABSAKK = CABS1( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
@@ -257,7 +278,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -302,7 +323,7 @@
*
KP = IMAX
*
-* copy column KW-1 of W to column KW
+* copy column KW-1 of W to column KW of W
*
CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
@@ -314,59 +335,117 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
KKW = NB + KK - N
*
-* Updated column KP is already stored in column KKW of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ A( KP, KP ) = A( KK, KK )
+ CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
- CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( KP.GT.1 )
+ $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
-* Interchange rows KK and KP in last KK columns of A and W
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
*
- CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
-* 1-by-1 pivot block D(k): column KW of W now holds
+* 1-by-1 pivot block D(k): column kw of W now holds
*
-* W(k) = U(k)*D(k)
+* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
-* Store U(k) in column k of A
+* Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored.
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = CONE / A( K, K )
CALL CSCAL( K-1, R1, A( 1, K ), 1 )
+*
ELSE
*
-* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
-* hold
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
-* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
+*
+* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored.
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
-* Store U(k) and U(k-1) in columns k and k-1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = CONE / ( D11*D22-CONE )
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
D21 = T / D21
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
@@ -379,7 +458,9 @@
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -423,20 +504,28 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
-* in columns k+1:n
+* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J + 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
J = J + 1
- END IF
- J = J + 1
- IF( JP.NE.JJ .AND. J.LE.N )
- $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
- IF( J.LE.N )
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
@@ -473,7 +562,8 @@
ABSAKK = CABS1( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
@@ -484,7 +574,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -528,7 +618,7 @@
*
KP = IMAX
*
-* copy column K+1 of W to column K
+* copy column K+1 of W to column K of W
*
CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
@@ -540,22 +630,36 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
-* Updated column KP is already stored in column KK of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
- CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+ A( KP, KP ) = A( KK, KK )
+ CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ IF( KP.LT.N )
+ $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
-* Interchange rows KK and KP in first KK columns of A and W
+* Interchange rows KK and KP in first K-1 columns of A
+* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
*
- CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ IF( K.GT.1 )
+ $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@@ -563,17 +667,23 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
-* W(k) = L(k)*D(k)
+* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
-* Store L(k) in column k of A
+* Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = CONE / A( K, K )
CALL CSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
+*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@@ -582,16 +692,52 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
+*
+* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored)
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
-* Store L(k) and L(k+1) in columns k and k+1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
@@ -603,7 +749,9 @@
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -648,20 +796,28 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
-* in columns 1:k-1
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J - 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
J = J - 1
- END IF
- J = J - 1
- IF( JP.NE.JJ .AND. J.GE.1 )
- $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
- IF( J.GE.1 )
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
diff --git a/lapack-netlib/SRC/clasyf_rook.f b/lapack-netlib/SRC/clasyf_rook.f
new file mode 100644
index 000000000..b83f54188
--- /dev/null
+++ b/lapack-netlib/SRC/clasyf_rook.f
@@ -0,0 +1,900 @@
+*> \brief \b CLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CLASYF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CLASYF_ROOK computes a partial factorization of a complex symmetric
+*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> CLASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*> On exit, A contains details of the partial factorization.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CONE, CZERO
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK,
+ $ KW, KKW, KP, KSTEP, P, II
+ REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
+ COMPLEX D11, D12, D21, D22, R1, T, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ICAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CCOPY, CGEMM, CGEMV, CSCAL, CSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT, AIMAG, REAL
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL CCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL CCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL CGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ STEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL CCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL CCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL CSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL CSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = CONE / ( D11*D22-CONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in columns k+1:n
+*
+ J = K + 1
+ 60 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J + 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J + 1
+ IF( JP2.NE.JJ .AND. J.LE.N )
+ $ CALL CSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
+ JJ = J - 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL CSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LE.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL CCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ STEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL CCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL CCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL CSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL CSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
+ $ CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* in columns 1:k-1
+*
+ J = K - 1
+ 120 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J - 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J - 1
+ IF( JP2.NE.JJ .AND. J.GE.1 )
+ $ CALL CSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
+ JJ = J + 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL CSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GE.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of CLASYF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/cstemr.f b/lapack-netlib/SRC/cstemr.f
index d3831d10f..0089343ff 100644
--- a/lapack-netlib/SRC/cstemr.f
+++ b/lapack-netlib/SRC/cstemr.f
@@ -311,7 +311,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -329,10 +329,10 @@
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
@@ -408,6 +408,7 @@
WU = ZERO
IIL = 0
IIU = 0
+ NSPLIT = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
diff --git a/lapack-netlib/SRC/csycon_rook.f b/lapack-netlib/SRC/csycon_rook.f
new file mode 100644
index 000000000..217bae176
--- /dev/null
+++ b/lapack-netlib/SRC/csycon_rook.f
@@ -0,0 +1,255 @@
+*> \brief \b CSYCON_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYCON_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND,
+* WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYCON_ROOK estimates the reciprocal of the condition number (in the
+*> 1-norm) of a complex symmetric matrix A using the factorization
+*> A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is REAL
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is REAL
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (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
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLACN2, CSYTRS_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYCON_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL CSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of CSYCON_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/csysv_rook.f b/lapack-netlib/SRC/csysv_rook.f
new file mode 100644
index 000000000..2e613628a
--- /dev/null
+++ b/lapack-netlib/SRC/csysv_rook.f
@@ -0,0 +1,293 @@
+*> \brief CSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYSV_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+* LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYSV_ROOK computes the solution to a complex system of linear
+*> equations
+*> A * X = B,
+*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*> matrices.
+*>
+*> The diagonal pivoting method is used to factor A as
+*> A = U * D * U**T, if UPLO = 'U', or
+*> A = L * D * L**T, if UPLO = 'L',
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> CSYTRF_ROOK is called to compute the factorization of a complex
+*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method.
+*>
+*> The factored form of A is then used to solve the system
+*> of equations A * X = B by calling CSYTRS_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order of the
+*> matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, if INFO = 0, the block diagonal matrix D and the
+*> multipliers used to obtain the factor U or L from the
+*> factorization A = U*D*U**T or A = L*D*L**T as computed by
+*> CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by CSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \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 length of WORK. LWORK >= 1, and for best performance
+*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+*> CSYTRF_ROOK.
+*>
+*> TRS will be done with Level 2 BLAS
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, so the solution could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complexSYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CSYTRF_ROOK, CSYTRS_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYSV_ROOK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**T or A = L*D*L**T.
+*
+ CALL CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+* Solve with TRS_ROOK ( Use Level 2 BLAS)
+*
+ CALL CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of CSYSV_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/csytf2.f b/lapack-netlib/SRC/csytf2.f
index c1889f120..b7dc56f60 100644
--- a/lapack-netlib/SRC/csytf2.f
+++ b/lapack-netlib/SRC/csytf2.f
@@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complexSYcomputational
*
@@ -182,10 +191,10 @@
* =====================================================================
SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -273,7 +282,8 @@
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, A( 1, K ), 1 )
@@ -284,7 +294,8 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN
*
-* Column K is zero or NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -441,7 +452,8 @@
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
@@ -452,7 +464,8 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN
*
-* Column K is zero or NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
diff --git a/lapack-netlib/SRC/csytf2_rook.f b/lapack-netlib/SRC/csytf2_rook.f
new file mode 100644
index 000000000..2a80375d3
--- /dev/null
+++ b/lapack-netlib/SRC/csytf2_rook.f
@@ -0,0 +1,821 @@
+*> \brief \b CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTF2_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYTF2_ROOK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, U**T is the transpose of U, and D is symmetric and
+*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CONE
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
+ COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ICAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CSCAL, CSWAP, CSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT, AIMAG, REAL
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTF2_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL CSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL CSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL CSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of CSYTF2_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/csytrf_rook.f b/lapack-netlib/SRC/csytrf_rook.f
new file mode 100644
index 000000000..d4169d744
--- /dev/null
+++ b/lapack-netlib/SRC/csytrf_rook.f
@@ -0,0 +1,393 @@
+*> \brief \b CSYTRF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTRF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYTRF_ROOK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*> The form of the factorization is
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLASYF_ROOK, CSYTF2_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'CSYTRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTRF_ROOK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'CSYTRF_ROOK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by CLASYF_ROOK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL CLASYF_ROOK( UPLO, K, NB, KB, A, LDA,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL CSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by CLASYF_ROOK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL CLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL CSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
+ $ IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of CSYTRF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/csytri_rook.f b/lapack-netlib/SRC/csytri_rook.f
new file mode 100644
index 000000000..0b57a713c
--- /dev/null
+++ b/lapack-netlib/SRC/csytri_rook.f
@@ -0,0 +1,451 @@
+*> \brief \b CSYTRI_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTRI_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYTRI_ROOK computes the inverse of a complex symmetric
+*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
+*> computed by CSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the block diagonal matrix D and the multipliers
+*> used to obtain the factor U or L as computed by CSYTRF_ROOK.
+*>
+*> On exit, if INFO = 0, the (symmetric) inverse of the original
+*> matrix. If UPLO = 'U', the upper triangular part of the
+*> inverse is formed and the part of A below the diagonal is not
+*> referenced; if UPLO = 'L' the lower triangular part of the
+*> inverse is formed and the part of A above the diagonal is
+*> not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (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, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX CONE, CZERO
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KP, KSTEP
+ COMPLEX AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ COMPLEX CDOTU
+ EXTERNAL LSAME, CDOTU
+* ..
+* .. External Subroutines ..
+ EXTERNAL CCOPY, CSWAP, CSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTRI_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = CONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = A( K, K+1 )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-CONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ CDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ CDOTU( K-1, WORK, 1, A( 1, K+1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K+1 with -IPIV(K) and
+* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+*
+ K = K + 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K + 1
+ GO TO 30
+ 40 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 50 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = CONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = A( K, K-1 )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-CONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ CDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ CZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ CDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K-1 with -IPIV(K) and
+* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+*
+ K = K - 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K - 1
+ GO TO 50
+ 60 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of CSYTRI_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/csytrs_rook.f b/lapack-netlib/SRC/csytrs_rook.f
new file mode 100644
index 000000000..44727212c
--- /dev/null
+++ b/lapack-netlib/SRC/csytrs_rook.f
@@ -0,0 +1,484 @@
+*> \brief \b CSYTRS_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTRS_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYTRS_ROOK solves a system of linear equations A*X = B with
+*> a complex symmetric matrix A using the factorization A = U*D*U**T or
+*> A = L*D*L**T computed by CSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX CONE
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMV, CGERU, CSCAL, CSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTRS_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL CGERU( K-1, NRHS, -CONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL CSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.GT.2 ) THEN
+ CALL CGERU( K-2, NRHS,-CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL CGERU( K-2, NRHS,-CONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / AKM1K
+ DENOM = AKM1*AK - CONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U**T *X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U**T(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.GT.1 )
+ $ CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B,
+ $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B,
+ $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B,
+ $ LDB, A( 1, K+1 ), 1, CONE, B( K+1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL CGERU( N-K, NRHS, -CONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL CSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL CGERU( N-K-1, NRHS,-CONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL CGERU( N-K-1, NRHS,-CONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / AKM1K
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - CONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L**T *X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L**T(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K-1 ), 1, CONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of CSYTRS_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/ctpmqrt.f b/lapack-netlib/SRC/ctpmqrt.f
index abfdae87c..08929b226 100644
--- a/lapack-netlib/SRC/ctpmqrt.f
+++ b/lapack-netlib/SRC/ctpmqrt.f
@@ -175,7 +175,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -216,10 +216,10 @@
SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
$ A, LDA, B, LDB, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -235,7 +235,7 @@
* ..
* .. Local Scalars ..
LOGICAL LEFT, RIGHT, TRAN, NOTRAN
- INTEGER I, IB, MB, LB, KF, Q
+ INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -257,10 +257,12 @@
TRAN = LSAME( TRANS, 'C' )
NOTRAN = LSAME( TRANS, 'N' )
*
- IF( LEFT ) THEN
- Q = M
+ IF ( LEFT ) THEN
+ LDVQ = MAX( 1, M )
+ LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
- Q = N
+ LDVQ = MAX( 1, N )
+ LDAQ = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
INFO = -1
@@ -274,13 +276,13 @@
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
INFO = -6
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
- ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
+ ELSE IF( LDV.LT.LDVQ ) THEN
INFO = -9
ELSE IF( LDT.LT.NB ) THEN
INFO = -11
- ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ ELSE IF( LDA.LT.LDAQ ) THEN
INFO = -13
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -15
diff --git a/lapack-netlib/SRC/ctpqrt.f b/lapack-netlib/SRC/ctpqrt.f
index f29ddf979..4dc173f0b 100644
--- a/lapack-netlib/SRC/ctpqrt.f
+++ b/lapack-netlib/SRC/ctpqrt.f
@@ -132,7 +132,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -189,10 +189,10 @@
SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK,
$ INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDT, N, M, L, NB
@@ -219,9 +219,9 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
INFO = -3
- ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
diff --git a/lapack-netlib/SRC/cunbdb.f b/lapack-netlib/SRC/cunbdb.f
index 248070a16..36c52d18f 100644
--- a/lapack-netlib/SRC/cunbdb.f
+++ b/lapack-netlib/SRC/cunbdb.f
@@ -255,7 +255,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -287,10 +287,10 @@
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIGNS, TRANS
@@ -420,19 +420,33 @@
THETA(I) = ATAN2( SCNRM2( M-P-I+1, X21(I,I), 1 ),
$ SCNRM2( P-I+1, X11(I,I), 1 ) )
*
- CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( P .GT. I ) THEN
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ ELSE IF ( P .EQ. I ) THEN
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
+ END IF
X11(I,I) = ONE
- CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF ( M-P .GT. I ) THEN
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
+ $ TAUP2(I) )
+ ELSE IF ( M-P .EQ. I ) THEN
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
+ $ TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
- CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK )
- CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
- $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
- CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
- $ X21(I,I+1), LDX21, WORK )
- CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
- $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
+ IF ( Q .GT. I ) THEN
+ CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1,
+ $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK )
+ CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
+ $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
+ CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q ) THEN
CALL CSCAL( Q-I, CMPLX( -Z1*Z3*SIN(THETA(I)), 0.0E0 ),
@@ -451,13 +465,25 @@
*
IF( I .LT. Q ) THEN
CALL CLACGV( Q-I, X11(I,I+1), LDX11 )
- CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
- $ TAUQ1(I) )
+ IF ( I .EQ. Q-1 ) THEN
+ CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11,
+ $ TAUQ1(I) )
+ ELSE
+ CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
+ $ TAUQ1(I) )
+ END IF
X11(I,I+1) = ONE
END IF
- CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 )
- CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 )
+ IF ( M-Q .EQ. I ) THEN
+ CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
+ END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@@ -466,10 +492,14 @@
CALL CLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
END IF
- CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
- CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X22(I+1,I), LDX22, WORK )
+ IF ( P .GT. I ) THEN
+ CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
+ IF ( M-P .GT. I ) THEN
+ CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q )
$ CALL CLACGV( Q-I, X11(I,I+1), LDX11 )
@@ -484,12 +514,19 @@
CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4, 0.0E0 ), X12(I,I),
$ LDX12 )
CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 )
- CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( I .GE. M-Q ) THEN
+ CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
X12(I,I) = ONE
*
- CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ IF ( P .GT. I ) THEN
+ CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL CLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
@@ -548,8 +585,13 @@
*
CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
X11(I,I) = ONE
- CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
- $ TAUP2(I) )
+ IF ( I .EQ. M-P ) THEN
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
+ $ TAUP2(I) )
+ ELSE
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
+ $ TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
CALL CLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
@@ -594,9 +636,11 @@
END IF
CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)),
$ X12(I,I+1), LDX12, WORK )
- CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
- $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
-*
+
+ IF ( M-P .GT. I ) THEN
+ CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
+ END IF
END DO
*
* Reduce columns Q + 1, ..., P of X12, X22
@@ -607,8 +651,10 @@
CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
X12(I,I) = ONE
*
- CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)),
- $ X12(I,I+1), LDX12, WORK )
+ IF ( P .GT. I ) THEN
+ CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL CLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
$ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK )
@@ -624,10 +670,11 @@
CALL CLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
$ TAUQ2(P+I) )
X22(P+I,Q+I) = ONE
-*
- CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
- $ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, WORK )
-*
+ IF ( M-P-Q .NE. I ) THEN
+ CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
+ $ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22,
+ $ WORK )
+ END IF
END DO
*
END IF
diff --git a/lapack-netlib/SRC/cunbdb1.f b/lapack-netlib/SRC/cunbdb1.f
new file mode 100644
index 000000000..fea26b21a
--- /dev/null
+++ b/lapack-netlib/SRC/cunbdb1.f
@@ -0,0 +1,327 @@
+*> \brief \b CUNBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines CUNBDB2, CUNBDB3, and CUNBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE
+ PARAMETER ( ONE = (1.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA
+ EXTERNAL CLACGV
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( REAL( X21(I,I) ), REAL( X11(I,I) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL CSROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
+ $ S )
+ CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
+ CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = REAL( X21(I,I+1) )
+ X21(I,I+1) = ONE
+ CALL CLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
+ C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL CUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB1
+*
+ END
+
diff --git a/lapack-netlib/SRC/cunbdb2.f b/lapack-netlib/SRC/cunbdb2.f
new file mode 100644
index 000000000..cec00f93c
--- /dev/null
+++ b/lapack-netlib/SRC/cunbdb2.f
@@ -0,0 +1,337 @@
+*> \brief \b CUNBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines CUNBDB1, CUNBDB3, and CUNBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX NEGONE, ONE
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0),
+ $ ONE = (1.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C,
+ $ S )
+ END IF
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = REAL( X11(I,I) )
+ X11(I,I) = ONE
+ CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SCNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL CUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL CSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL CLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( REAL( X11(I+1,I) ), REAL( X21(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL CLARF( 'L', P-I, Q-I, X11(I+1,I), 1, CONJG(TAUP1(I)),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB2
+*
+ END
+
diff --git a/lapack-netlib/SRC/cunbdb3.f b/lapack-netlib/SRC/cunbdb3.f
new file mode 100644
index 000000000..5451ef003
--- /dev/null
+++ b/lapack-netlib/SRC/cunbdb3.f
@@ -0,0 +1,336 @@
+*> \brief \b CUNBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB3 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines CUNBDB1, CUNBDB2, and CUNBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE
+ PARAMETER ( ONE = (1.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL CSROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C,
+ $ S )
+ END IF
+*
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = REAL( X21(I,I) )
+ X21(I,I) = ONE
+ CALL CLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ C = SQRT( SCNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL CUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( REAL( X21(I+1,I) ), REAL( X11(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL CLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, CONJG(TAUP2(I)),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB3
+*
+ END
+
diff --git a/lapack-netlib/SRC/cunbdb4.f b/lapack-netlib/SRC/cunbdb4.f
new file mode 100644
index 000000000..bc948a30f
--- /dev/null
+++ b/lapack-netlib/SRC/cunbdb4.f
@@ -0,0 +1,385 @@
+*> \brief \b CUNBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB4 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines CUNBDB1, CUNBDB2, and CUNBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is COMPLEX array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0),
+ $ ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL CUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL CSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL CLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( REAL( PHANTOM(1) ), REAL( PHANTOM(P+1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL CLARF( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), X11,
+ $ LDX11, WORK(ILARF) )
+ CALL CLARF( 'L', M-P, Q, PHANTOM(P+1), 1, CONJG(TAUP2(1)),
+ $ X21, LDX21, WORK(ILARF) )
+ ELSE
+ CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL CSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL CLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( REAL( X11(I,I-1) ), REAL( X21(I,I-1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ CONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ CONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = REAL( X21(I,I) )
+ X21(I,I) = ONE
+ CALL CLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL CLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB4
+*
+ END
+
diff --git a/lapack-netlib/SRC/cunbdb5.f b/lapack-netlib/SRC/cunbdb5.f
new file mode 100644
index 000000000..d3a7d1535
--- /dev/null
+++ b/lapack-netlib/SRC/cunbdb5.f
@@ -0,0 +1,274 @@
+*> \brief \b CUNBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB5 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL CUNBDB6, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB5
+*
+ END
+
diff --git a/lapack-netlib/SRC/cunbdb6.f b/lapack-netlib/SRC/cunbdb6.f
new file mode 100644
index 000000000..943e52249
--- /dev/null
+++ b/lapack-netlib/SRC/cunbdb6.f
@@ -0,0 +1,313 @@
+*> \brief \b CUNBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB6 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0,
+ $ REALZERO = 0.0E0 )
+ COMPLEX NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0),
+ $ ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMV, CLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of CUNBDB6
+*
+ END
+
diff --git a/lapack-netlib/SRC/cuncsd.f b/lapack-netlib/SRC/cuncsd.f
index fef03dd51..ca3922da4 100644
--- a/lapack-netlib/SRC/cuncsd.f
+++ b/lapack-netlib/SRC/cuncsd.f
@@ -308,7 +308,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@@ -320,10 +320,10 @@
$ LDV2T, WORK, LWORK, RWORK, LRWORK,
$ IWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS
@@ -356,7 +356,7 @@
$ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN,
$ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN,
$ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN,
- $ LORGQRWORKOPT, LWORKMIN, LWORKOPT
+ $ LORGQRWORKOPT, LWORKMIN, LWORKOPT, P1, Q1
LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2,
$ WANTV1T, WANTV2T
INTEGER LRWORKMIN, LRWORKOPT
@@ -392,9 +392,22 @@
INFO = -8
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -9
- ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR.
- $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN
- INFO = -11
+ ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -11
+ ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN
+ INFO = -11
+ ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN
+ INFO = -13
+ ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -13
+ ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -15
+ ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN
+ INFO = -15
+ ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -17
+ ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -17
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -20
ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN
@@ -458,9 +471,10 @@
IB22D = IB21E + MAX( 1, Q - 1 )
IB22E = IB22D + MAX( 1, Q )
IBBCSD = IB22E + MAX( 1, Q - 1 )
- CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0,
- $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0,
- $ 0, 0, 0, 0, 0, 0, 0, RWORK, -1, CHILDINFO )
+ CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q,
+ $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T,
+ $ V2T, LDV2T, THETA, THETA, THETA, THETA, THETA,
+ $ THETA, THETA, THETA, RWORK, -1, CHILDINFO )
LBBCSDWORKOPT = INT( RWORK(1) )
LBBCSDWORKMIN = LBBCSDWORKOPT
LRWORKOPT = IBBCSD + LBBCSDWORKOPT - 1
@@ -474,19 +488,19 @@
ITAUQ1 = ITAUP2 + MAX( 1, M - P )
ITAUQ2 = ITAUQ1 + MAX( 1, Q )
IORGQR = ITAUQ2 + MAX( 1, M - Q )
- CALL CUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
+ CALL CUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGQRWORKOPT = INT( WORK(1) )
LORGQRWORKMIN = MAX( 1, M - Q )
IORGLQ = ITAUQ2 + MAX( 1, M - Q )
- CALL CUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
+ CALL CUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGLQWORKOPT = INT( WORK(1) )
LORGLQWORKMIN = MAX( 1, M - Q )
IORBDB = ITAUQ2 + MAX( 1, M - Q )
CALL CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
- $ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK,
- $ -1, CHILDINFO )
+ $ X21, LDX21, X22, LDX22, THETA, THETA, U1, U2,
+ $ V1T, V2T, WORK, -1, CHILDINFO )
LORBDBWORKOPT = INT( WORK(1) )
LORBDBWORKMIN = LORBDBWORKOPT
LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT,
@@ -551,10 +565,14 @@
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
CALL CLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T )
- CALL CLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
- $ V2T(P+1,P+1), LDV2T )
- CALL CUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
- $ WORK(IORGLQ), LORGLQWORK, INFO )
+ IF( M-P .GT. Q ) THEN
+ CALL CLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
+ $ V2T(P+1,P+1), LDV2T )
+ END IF
+ IF( M .GT. Q ) THEN
+ CALL CUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
+ $ WORK(IORGLQ), LORGLQWORK, INFO )
+ END IF
END IF
ELSE
IF( WANTU1 .AND. P .GT. 0 ) THEN
@@ -579,9 +597,13 @@
$ WORK(IORGQR), LORGQRWORK, INFO )
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
+ P1 = MIN( P+1, M )
+ Q1 = MIN( Q+1, M )
CALL CLACPY( 'L', M-Q, P, X12, LDX12, V2T, LDV2T )
- CALL CLACPY( 'L', M-P-Q, M-P-Q, X22(P+1,Q+1), LDX22,
- $ V2T(P+1,P+1), LDV2T )
+ IF ( M .GT. P+Q ) THEN
+ CALL CLACPY( 'L', M-P-Q, M-P-Q, X22(P1,Q1), LDX22,
+ $ V2T(P+1,P+1), LDV2T )
+ END IF
CALL CUNGQR( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
$ WORK(IORGQR), LORGQRWORK, INFO )
END IF
diff --git a/lapack-netlib/SRC/cuncsd2by1.f b/lapack-netlib/SRC/cuncsd2by1.f
new file mode 100644
index 000000000..74364cec3
--- /dev/null
+++ b/lapack-netlib/SRC/cuncsd2by1.f
@@ -0,0 +1,757 @@
+*> \brief \b CUNCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNCSD2BY1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+* REAL RWORK(*)
+* REAL THETA(*)
+* COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is COMPLEX array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is COMPLEX array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is COMPLEX array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is COMPLEX array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*> \verbatim
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (MAX(1,LRWORK))
+*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*> If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LRWORK
+*> \verbatim
+*> LRWORK is INTEGER
+*> The dimension of the array RWORK.
+*>
+*> If LRWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the RWORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LRWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: CBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*
+*> \par References:
+*> ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+ INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+ REAL RWORK(*)
+ REAL THETA(*)
+ COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL CBBCSD, CCOPY, CLACPY, CLAPMR, CLAPMT, CUNBDB1,
+ $ CUNBDB2, CUNBDB3, CUNBDB4, CUNGLQ, CUNGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-----------------------------------------|
+* | LWORKOPT (1) |
+* |-----------------------------------------|
+* | TAUP1 (MAX(1,P)) |
+* | TAUP2 (MAX(1,M-P)) |
+* | TAUQ1 (MAX(1,Q)) |
+* |-----------------------------------------|
+* | CUNBDB WORK | CUNGQR WORK | CUNGLQ WORK |
+* | | | |
+* | | | |
+* | | | |
+* | | | |
+* |-----------------------------------------|
+* RWORK layout:
+* |------------------|
+* | LRWORKOPT (1) |
+* |------------------|
+* | PHI (MAX(1,R-1)) |
+* |------------------|
+* | B11D (R) |
+* | B11E (R-1) |
+* | B12D (R) |
+* | B12E (R-1) |
+* | B21D (R) |
+* | B21E (R-1) |
+* | B22D (R) |
+* | B22E (R-1) |
+* | CBBCSD RWORK |
+* |------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + MAX( 1, R )
+ IB12D = IB11E + MAX( 1, R - 1 )
+ IB12E = IB12D + MAX( 1, R )
+ IB21D = IB12E + MAX( 1, R - 1 )
+ IB21E = IB21D + MAX( 1, R )
+ IB22D = IB21E + MAX( 1, R - 1 )
+ IB22E = IB22D + MAX( 1, R )
+ IBBCSD = IB22E + MAX( 1, R - 1 )
+ ITAUP1 = 2
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE
+ CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL CUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ END IF
+ LRWORKMIN = IBBCSD+LBBCSD-1
+ LRWORKOPT = LRWORKMIN
+ RWORK(1) = LRWORKOPT
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL CLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL CUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL CLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL CLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL CLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL CLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2,
+ $ U1, LDU1, RWORK(IB11D), RWORK(IB11E),
+ $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D),
+ $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E),
+ $ RWORK(IBBCSD), LBBCSD, CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL CLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL CLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL CCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL CLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL CUNGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL CCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL CLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL CLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL CLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL CLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL CLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL CLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of CUNCSD2BY1
+*
+ END
+
diff --git a/lapack-netlib/SRC/dbbcsd.f b/lapack-netlib/SRC/dbbcsd.f
index 479168e26..3e54909f2 100644
--- a/lapack-netlib/SRC/dbbcsd.f
+++ b/lapack-netlib/SRC/dbbcsd.f
@@ -322,7 +322,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@@ -332,10 +332,10 @@
$ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E,
$ B22D, B22E, WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
@@ -358,8 +358,8 @@
PARAMETER ( HUNDRED = 100.0D0, MEIGHTH = -0.125D0,
$ ONE = 1.0D0, PIOVER2 = 1.57079632679489662D0,
$ TEN = 10.0D0, ZERO = 0.0D0 )
- DOUBLE PRECISION NEGONECOMPLEX
- PARAMETER ( NEGONECOMPLEX = -1.0D0 )
+ DOUBLE PRECISION NEGONE
+ PARAMETER ( NEGONE = -1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12,
@@ -477,7 +477,10 @@
* Initial deflation
*
IMAX = Q
- DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) )
+ DO WHILE( IMAX .GT. 1 )
+ IF( PHI(IMAX-1) .NE. ZERO ) THEN
+ EXIT
+ END IF
IMAX = IMAX - 1
END DO
IMIN = IMAX - 1
@@ -939,9 +942,9 @@
B21D(IMAX) = -B21D(IMAX)
IF( WANTV1T ) THEN
IF( COLMAJOR ) THEN
- CALL DSCAL( Q, NEGONECOMPLEX, V1T(IMAX,1), LDV1T )
+ CALL DSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T )
ELSE
- CALL DSCAL( Q, NEGONECOMPLEX, V1T(1,IMAX), 1 )
+ CALL DSCAL( Q, NEGONE, V1T(1,IMAX), 1 )
END IF
END IF
END IF
@@ -962,9 +965,9 @@
B12D(IMAX) = -B12D(IMAX)
IF( WANTU1 ) THEN
IF( COLMAJOR ) THEN
- CALL DSCAL( P, NEGONECOMPLEX, U1(1,IMAX), 1 )
+ CALL DSCAL( P, NEGONE, U1(1,IMAX), 1 )
ELSE
- CALL DSCAL( P, NEGONECOMPLEX, U1(IMAX,1), LDU1 )
+ CALL DSCAL( P, NEGONE, U1(IMAX,1), LDU1 )
END IF
END IF
END IF
@@ -972,9 +975,9 @@
B22D(IMAX) = -B22D(IMAX)
IF( WANTU2 ) THEN
IF( COLMAJOR ) THEN
- CALL DSCAL( M-P, NEGONECOMPLEX, U2(1,IMAX), 1 )
+ CALL DSCAL( M-P, NEGONE, U2(1,IMAX), 1 )
ELSE
- CALL DSCAL( M-P, NEGONECOMPLEX, U2(IMAX,1), LDU2 )
+ CALL DSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 )
END IF
END IF
END IF
@@ -984,9 +987,9 @@
IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN
IF( WANTV2T ) THEN
IF( COLMAJOR ) THEN
- CALL DSCAL( M-Q, NEGONECOMPLEX, V2T(IMAX,1), LDV2T )
+ CALL DSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T )
ELSE
- CALL DSCAL( M-Q, NEGONECOMPLEX, V2T(1,IMAX), 1 )
+ CALL DSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 )
END IF
END IF
END IF
diff --git a/lapack-netlib/SRC/dgebal.f b/lapack-netlib/SRC/dgebal.f
index 5d7ed035c..80ae26812 100644
--- a/lapack-netlib/SRC/dgebal.f
+++ b/lapack-netlib/SRC/dgebal.f
@@ -121,7 +121,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@@ -160,10 +160,10 @@
* =====================================================================
SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
@@ -192,8 +192,8 @@
* .. External Functions ..
LOGICAL DISNAN, LSAME
INTEGER IDAMAX
- DOUBLE PRECISION DLAMCH
- EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH
+ DOUBLE PRECISION DLAMCH, DNRM2
+ EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSWAP, XERBLA
@@ -312,19 +312,14 @@
SFMAX1 = ONE / SFMIN1
SFMIN2 = SFMIN1*SCLFAC
SFMAX2 = ONE / SFMIN2
+*
140 CONTINUE
NOCONV = .FALSE.
*
DO 200 I = K, L
- C = ZERO
- R = ZERO
-*
- DO 150 J = K, L
- IF( J.EQ.I )
- $ GO TO 150
- C = C + ABS( A( J, I ) )
- R = R + ABS( A( I, J ) )
- 150 CONTINUE
+*
+ C = DNRM2( L-K+1, A( K, I ), 1 )
+ R = DNRM2( L-K+1, A( I, K ), LDA )
ICA = IDAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = IDAMAX( N-K+1, A( I, K ), LDA )
diff --git a/lapack-netlib/SRC/dgemqrt.f b/lapack-netlib/SRC/dgemqrt.f
index 99b396822..ef79221c3 100644
--- a/lapack-netlib/SRC/dgemqrt.f
+++ b/lapack-netlib/SRC/dgemqrt.f
@@ -160,7 +160,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@@ -168,10 +168,10 @@
SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -225,7 +225,7 @@
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN
INFO = -5
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN
INFO = -6
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
INFO = -8
diff --git a/lapack-netlib/SRC/dgeqrt.f b/lapack-netlib/SRC/dgeqrt.f
index 91dfad1e6..0ba5c7fcf 100644
--- a/lapack-netlib/SRC/dgeqrt.f
+++ b/lapack-netlib/SRC/dgeqrt.f
@@ -108,7 +108,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@@ -141,10 +141,10 @@
* =====================================================================
SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDT, M, N, NB
@@ -173,7 +173,7 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN
+ ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
diff --git a/lapack-netlib/SRC/dgesdd.f b/lapack-netlib/SRC/dgesdd.f
index 31a811a5a..6fc753329 100644
--- a/lapack-netlib/SRC/dgesdd.f
+++ b/lapack-netlib/SRC/dgesdd.f
@@ -175,8 +175,7 @@
*> LWORK >= 3*min(M,N) +
*> max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
*> If JOBZ = 'S' or 'A'
-*> LWORK >= 3*min(M,N) +
-*> max(max(M,N),4*min(M,N)*min(M,N)+3*min(M,N)+max(M,N)).
+*> LWORK >= min(M,N)*(6+4*min(M,N))+max(M,N)
*> For good performance, LWORK should generally be larger.
*> If LWORK = -1 but other input arguments are legal, WORK(1)
*> returns the optimal LWORK.
@@ -203,7 +202,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup doubleGEsing
*
@@ -217,10 +216,10 @@
SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
-* -- LAPACK driver routine (version 3.4.2) --
+* -- LAPACK driver routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ
diff --git a/lapack-netlib/SRC/dgetc2.f b/lapack-netlib/SRC/dgetc2.f
index 6ae1a204b..7e43a0236 100644
--- a/lapack-netlib/SRC/dgetc2.f
+++ b/lapack-netlib/SRC/dgetc2.f
@@ -98,7 +98,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup doubleGEauxiliary
*
@@ -111,10 +111,10 @@
* =====================================================================
SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
@@ -203,6 +203,11 @@
INFO = N
A( N, N ) = SMIN
END IF
+*
+* Set last pivots to N
+*
+ IPIV( N ) = N
+ JPIV( N ) = N
*
RETURN
*
diff --git a/lapack-netlib/SRC/dhgeqz.f b/lapack-netlib/SRC/dhgeqz.f
index f6989aae2..bf6e414d7 100644
--- a/lapack-netlib/SRC/dhgeqz.f
+++ b/lapack-netlib/SRC/dhgeqz.f
@@ -282,7 +282,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@@ -304,10 +304,10 @@
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
$ LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
@@ -739,9 +739,9 @@
* Exceptional shift. Chosen for no particularly good reason.
* (Single shift only.)
*
- IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT.
+ IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST, ILAST-1 ) ).LT.
$ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN
- ESHIFT = ESHIFT + H( ILAST, ILAST-1 ) /
+ ESHIFT = H( ILAST, ILAST-1 ) /
$ T( ILAST-1, ILAST-1 )
ELSE
ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) )
@@ -759,6 +759,16 @@
$ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
$ S2, WR, WR2, WI )
*
+ IF ( ABS( (WR/S1)*T( ILAST, ILAST ) - H( ILAST, ILAST ) )
+ $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST )
+ $ - H( ILAST, ILAST ) ) ) THEN
+ TEMP = WR
+ WR = WR2
+ WR2 = TEMP
+ TEMP = S1
+ S1 = S2
+ S2 = TEMP
+ END IF
TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
IF( WI.NE.ZERO )
$ GO TO 200
diff --git a/lapack-netlib/SRC/dhsein.f b/lapack-netlib/SRC/dhsein.f
index d239a0ea8..b8244b828 100644
--- a/lapack-netlib/SRC/dhsein.f
+++ b/lapack-netlib/SRC/dhsein.f
@@ -108,6 +108,7 @@
*> \verbatim
*> H is DOUBLE PRECISION array, dimension (LDH,N)
*> The upper Hessenberg matrix H.
+*> If a NaN is detected in H, the routine will return with INFO=-6.
*> \endverbatim
*>
*> \param[in] LDH
@@ -243,7 +244,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@@ -262,10 +263,10 @@
$ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
$ IFAILR, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
@@ -291,9 +292,9 @@
$ WKR
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH, DLANHS
- EXTERNAL LSAME, DLAMCH, DLANHS
+ EXTERNAL LSAME, DLAMCH, DLANHS, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL DLAEIN, XERBLA
@@ -423,7 +424,10 @@
* has not ben computed before.
*
HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
- IF( HNORM.GT.ZERO ) THEN
+ IF( DISNAN( HNORM ) ) THEN
+ INFO = -6
+ RETURN
+ ELSE IF( HNORM.GT.ZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
diff --git a/lapack-netlib/SRC/dladiv.f b/lapack-netlib/SRC/dladiv.f
index 306a6b002..c22d56d2c 100644
--- a/lapack-netlib/SRC/dladiv.f
+++ b/lapack-netlib/SRC/dladiv.f
@@ -36,8 +36,9 @@
*> p + i*q = ---------
*> c + i*d
*>
-*> The algorithm is due to Robert L. Smith and can be found
-*> in D. Knuth, The art of Computer Programming, Vol.2, p.195
+*> The algorithm is due to Michael Baudin and Robert L. Smith
+*> and can be found in the paper
+*> "A Robust Complex Division in Scilab"
*> \endverbatim
*
* Arguments:
@@ -83,17 +84,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date January 2013
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* January 2013
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, D, P, Q
@@ -101,28 +102,152 @@
*
* =====================================================================
*
+* .. Parameters ..
+ DOUBLE PRECISION BS
+ PARAMETER ( BS = 2.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = 0.5D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+*
* .. Local Scalars ..
- DOUBLE PRECISION E, F
+ DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLADIV1
* ..
* .. Intrinsic Functions ..
- INTRINSIC ABS
+ INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
- IF( ABS( D ).LT.ABS( C ) ) THEN
- E = D / C
- F = C + D*E
- P = ( A+B*E ) / F
- Q = ( B-A*E ) / F
+ AA = A
+ BB = B
+ CC = C
+ DD = D
+ AB = MAX( ABS(A), ABS(B) )
+ CD = MAX( ABS(C), ABS(D) )
+ S = 1.0D0
+
+ OV = DLAMCH( 'Overflow threshold' )
+ UN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Epsilon' )
+ BE = BS / (EPS*EPS)
+
+ IF( AB >= HALF*OV ) THEN
+ AA = HALF * AA
+ BB = HALF * BB
+ S = TWO * S
+ END IF
+ IF( CD >= HALF*OV ) THEN
+ CC = HALF * CC
+ DD = HALF * DD
+ S = HALF * S
+ END IF
+ IF( AB <= UN*BS/EPS ) THEN
+ AA = AA * BE
+ BB = BB * BE
+ S = S / BE
+ END IF
+ IF( CD <= UN*BS/EPS ) THEN
+ CC = CC * BE
+ DD = DD * BE
+ S = S * BE
+ END IF
+ IF( ABS( D ).LE.ABS( C ) ) THEN
+ CALL DLADIV1(AA, BB, CC, DD, P, Q)
ELSE
- E = C / D
- F = D + C*E
- P = ( B+A*E ) / F
- Q = ( -A+B*E ) / F
+ CALL DLADIV1(BB, AA, DD, CC, P, Q)
+ Q = -Q
END IF
+ P = P * S
+ Q = Q * S
*
RETURN
*
* End of DLADIV
*
END
+
+
+
+ SUBROUTINE DLADIV1( A, B, C, D, P, Q )
+*
+* -- LAPACK auxiliary routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* January 2013
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, D, P, Q
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION R, T
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLADIV2
+ EXTERNAL DLADIV2
+* ..
+* .. Executable Statements ..
+*
+ R = D / C
+ T = ONE / (C + D * R)
+ P = DLADIV2(A, B, C, D, R, T)
+ A = -A
+ Q = DLADIV2(B, A, C, D, R, T)
+*
+ RETURN
+*
+* End of DLADIV1
+*
+ END
+
+ DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T )
+*
+* -- LAPACK auxiliary routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* January 2013
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, D, R, T
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION BR
+* ..
+* .. Executable Statements ..
+*
+ IF( R.NE.ZERO ) THEN
+ BR = B * R
+ if( BR.NE.ZERO ) THEN
+ DLADIV2 = (A + BR) * T
+ ELSE
+ DLADIV2 = A * T + (B * T) * R
+ END IF
+ ELSE
+ DLADIV2 = (A + D * (B / C)) * T
+ END IF
+*
+ RETURN
+*
+* End of DLADIV12
+*
+ END
diff --git a/lapack-netlib/SRC/dlaqp2.f b/lapack-netlib/SRC/dlaqp2.f
index 0c044366c..e138aeee1 100644
--- a/lapack-netlib/SRC/dlaqp2.f
+++ b/lapack-netlib/SRC/dlaqp2.f
@@ -122,7 +122,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup doubleOTHERauxiliary
*
@@ -149,10 +149,10 @@
SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, OFFSET
@@ -217,7 +217,7 @@
CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
END IF
*
- IF( I.LE.N ) THEN
+ IF( I.LT.N ) THEN
*
* Apply H(i)**T to A(offset+i:m,i+1:n) from the left.
*
diff --git a/lapack-netlib/SRC/dlarfb.f b/lapack-netlib/SRC/dlarfb.f
index 17218478a..18ec9bfd7 100644
--- a/lapack-netlib/SRC/dlarfb.f
+++ b/lapack-netlib/SRC/dlarfb.f
@@ -159,7 +159,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date June 2013
*
*> \ingroup doubleOTHERauxiliary
*
@@ -195,10 +195,10 @@
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@@ -217,12 +217,11 @@
* ..
* .. Local Scalars ..
CHARACTER TRANST
- INTEGER I, J, LASTV, LASTC, lastv2
+ INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
- INTEGER ILADLR, ILADLC
- EXTERNAL LSAME, ILADLR, ILADLC
+ EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DTRMM
@@ -252,58 +251,53 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
- LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C1**T
*
DO 10 J = 1, K
- CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
- CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
-* W := W + C2**T *V2
+* W := W + C2**T * V2
*
- CALL DGEMM( 'Transpose', 'No transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
- IF( LASTV.GT.K ) THEN
+ IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W**T
*
- CALL DGEMM( 'No transpose', 'Transpose',
- $ LASTV-K, LASTC, K,
- $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
- $ C( K+1, 1 ), LDC )
+ CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**T
*
- CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 30 J = 1, K
- DO 20 I = 1, LASTC
+ DO 20 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
20 CONTINUE
30 CONTINUE
@@ -311,58 +305,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
- LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
- CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
- CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
- CALL DGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**T
*
- CALL DGEMM( 'No transpose', 'Transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
- $ C( 1, K+1 ), LDC )
+ CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**T
*
- CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
- DO 50 I = 1, LASTC
+ DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
@@ -378,36 +367,31 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTC = ILADLC( M, N, C, LDC )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C2**T
*
DO 70 J = 1, K
- CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
+ CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
- CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
-* W := W + C1**T*V1
+* W := W + C1**T * V1
*
- CALL DGEMM( 'Transpose', 'No transpose',
- $ LASTC, K, M-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
@@ -415,57 +399,51 @@
*
* C1 := C1 - V1 * W**T
*
- CALL DGEMM( 'No transpose', 'Transpose',
- $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
- $ ONE, C, LDC )
+ CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
- CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 90 J = 1, K
- DO 80 I = 1, LASTC
- C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J)
+ DO 80 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTC = ILADLR( M, N, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
- CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+ CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
- CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
- CALL DGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, N-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
@@ -473,22 +451,20 @@
*
* C1 := C1 - W * V1**T
*
- CALL DGEMM( 'No transpose', 'Transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
- CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
- DO 110 I = 1, LASTC
- C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J)
+ DO 110 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
@@ -505,58 +481,53 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
- LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C1**T
*
DO 130 J = 1, K
- CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**T
*
- CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
-* W := W + C2**T*V2**T
+* W := W + C2**T * V2**T
*
- CALL DGEMM( 'Transpose', 'Transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+ $ WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
- IF( LASTV.GT.K ) THEN
+ IF( M.GT.K ) THEN
*
* C2 := C2 - V2**T * W**T
*
- CALL DGEMM( 'Transpose', 'Transpose',
- $ LASTV-K, LASTC, K,
- $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
- $ ONE, C( K+1, 1 ), LDC )
+ CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
- CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 150 J = 1, K
- DO 140 I = 1, LASTC
+ DO 140 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
140 CONTINUE
150 CONTINUE
@@ -564,58 +535,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
- LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
- CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**T
*
- CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2**T
*
- CALL DGEMM( 'No transpose', 'Transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
- CALL DGEMM( 'No transpose', 'No transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
- $ ONE, C( 1, K+1 ), LDC )
+ CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
- CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
- DO 170 I = 1, LASTC
+ DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
@@ -631,36 +597,31 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTC = ILADLC( M, N, C, LDC )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C2**T
*
DO 190 J = 1, K
- CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
+ CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**T
*
- CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**T * V1**T
*
- CALL DGEMM( 'Transpose', 'Transpose',
- $ LASTC, K, M-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
@@ -668,58 +629,51 @@
*
* C1 := C1 - V1**T * W**T
*
- CALL DGEMM( 'Transpose', 'Transpose',
- $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
- $ ONE, C, LDC )
+ CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 210 J = 1, K
- DO 200 I = 1, LASTC
- C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J)
+ DO 200 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
-* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTC = ILADLR( M, N, C, LDC )
+* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
- CALL DCOPY( LASTC, C( 1, N-K+J ), 1,
- $ WORK( 1, J ), 1 )
+ CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**T
*
- CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**T
*
- CALL DGEMM( 'No transpose', 'Transpose',
- $ LASTC, K, N-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
@@ -727,22 +681,20 @@
*
* C1 := C1 - W * V1
*
- CALL DGEMM( 'No transpose', 'No transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
- DO 230 I = 1, LASTC
- C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J)
+ DO 230 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
diff --git a/lapack-netlib/SRC/dlasd4.f b/lapack-netlib/SRC/dlasd4.f
index 838f7162d..71b6f7925 100644
--- a/lapack-netlib/SRC/dlasd4.f
+++ b/lapack-netlib/SRC/dlasd4.f
@@ -140,7 +140,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup auxOTHERauxiliary
*
@@ -153,10 +153,10 @@
* =====================================================================
SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
diff --git a/lapack-netlib/SRC/dlasyf.f b/lapack-netlib/SRC/dlasyf.f
index b16f2701d..de705e4ab 100644
--- a/lapack-netlib/SRC/dlasyf.f
+++ b/lapack-netlib/SRC/dlasyf.f
@@ -1,25 +1,25 @@
-*> \brief \b DLASYF computes a partial factorization of a real symmetric matrix, using the diagonal pivoting method.
+*> \brief \b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DLASYF + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download DLASYF + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
@@ -28,7 +28,7 @@
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), W( LDW, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -109,16 +109,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If UPLO = 'U', only the last KB elements of IPIV are set;
-*> if UPLO = 'L', only the first KB elements are set.
*>
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@@ -144,22 +154,32 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup doubleSYcomputational
*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*> \endverbatim
+*
* =====================================================================
SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -237,7 +257,8 @@
ABSAKK = ABS( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
@@ -248,7 +269,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -293,7 +314,7 @@
*
KP = IMAX
*
-* copy column KW-1 of W to column KW
+* copy column KW-1 of W to column KW of W
*
CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
@@ -305,60 +326,118 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
KKW = NB + KK - N
*
-* Updated column KP is already stored in column KKW of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ A( KP, KP ) = A( KK, KK )
+ CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
- CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( KP.GT.1 )
+ $ CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
-* Interchange rows KK and KP in last KK columns of A and W
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
*
- CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ IF( K.LT.N )
+ $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
-* 1-by-1 pivot block D(k): column KW of W now holds
+* 1-by-1 pivot block D(k): column kw of W now holds
*
-* W(k) = U(k)*D(k)
+* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
-* Store U(k) in column k of A
+* Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored.
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = ONE / A( K, K )
CALL DSCAL( K-1, R1, A( 1, K ), 1 )
+*
ELSE
*
-* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
-* hold
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
-* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
+*
+* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored.
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
-* Store U(k) and U(k-1) in columns k and k-1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
@@ -370,7 +449,9 @@
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -414,20 +495,28 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
-* in columns k+1:n
+* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J + 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
J = J + 1
- END IF
- J = J + 1
- IF( JP.NE.JJ .AND. J.LE.N )
- $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
- IF( J.LE.N )
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
@@ -464,7 +553,8 @@
ABSAKK = ABS( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
@@ -475,7 +565,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -518,7 +608,7 @@
*
KP = IMAX
*
-* copy column K+1 of W to column K
+* copy column K+1 of W to column K of W
*
CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
@@ -530,22 +620,36 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
-* Updated column KP is already stored in column KK of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
- CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+ A( KP, KP ) = A( KK, KK )
+ CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ IF( KP.LT.N )
+ $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
-* Interchange rows KK and KP in first KK columns of A and W
+* Interchange rows KK and KP in first K-1 columns of A
+* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
*
- CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ IF( K.GT.1 )
+ $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@@ -553,17 +657,23 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
-* W(k) = L(k)*D(k)
+* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
-* Store L(k) in column k of A
+* Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = ONE / A( K, K )
CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
+*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@@ -572,16 +682,52 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
+*
+* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored)
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
-* Store L(k) and L(k+1) in columns k and k+1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
@@ -593,7 +739,9 @@
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -638,20 +786,28 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
-* in columns 1:k-1
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J - 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
J = J - 1
- END IF
- J = J - 1
- IF( JP.NE.JJ .AND. J.GE.1 )
- $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
- IF( J.GE.1 )
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
diff --git a/lapack-netlib/SRC/dlasyf_rook.f b/lapack-netlib/SRC/dlasyf_rook.f
new file mode 100644
index 000000000..49ee7a6c9
--- /dev/null
+++ b/lapack-netlib/SRC/dlasyf_rook.f
@@ -0,0 +1,892 @@
+*> \brief \b DLASYF_ROOK *> DLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLASYF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* .. Scalar Arguments ..
+* CHARADLATER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLASYF_ROOK computes a partial factorization of a real symmetric
+*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*> On exit, A contains details of the partial factorization.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is DOUBLE PRECISION array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK,
+ $ KW, KKW, KP, KSTEP, P, II
+
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ DTEMP, R1, ROWMAX, T, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = ABS( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL DGEMV( 'No transpose', K, N-K, -ONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ ONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = ABS( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ DTEMP = ABS( W( ITEMP, KW-1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL DCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL DCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL DSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL DSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL DSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = ONE / ( D11*D22-ONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ ONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in columns k+1:n
+*
+ J = K + 1
+ 60 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J + 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J + 1
+ IF( JP2.NE.JJ .AND. J.LE.N )
+ $ CALL DSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
+ JJ = J - 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL DSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LE.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = ABS( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ ONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = ABS( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ DTEMP = ABS( W( ITEMP, K+1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL DCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL DCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL DSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL DSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
+ $ ONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* in columns 1:k-1
+*
+ J = K - 1
+ 120 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J - 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J - 1
+ IF( JP2.NE.JJ .AND. J.GE.1 )
+ $ CALL DSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
+ JJ = J + 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL DSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GE.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of DLASYF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/dorbdb.f b/lapack-netlib/SRC/dorbdb.f
index 5580f4ee8..9b56bf08c 100644
--- a/lapack-netlib/SRC/dorbdb.f
+++ b/lapack-netlib/SRC/dorbdb.f
@@ -255,7 +255,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@@ -287,10 +287,10 @@
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIGNS, TRANS
@@ -415,19 +415,36 @@
THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), 1 ),
$ DNRM2( P-I+1, X11(I,I), 1 ) )
*
- CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( P .GT. I ) THEN
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ ELSE IF( P .EQ. I ) THEN
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
+ END IF
X11(I,I) = ONE
- CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF ( M-P .GT. I ) THEN
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
+ $ TAUP2(I) )
+ ELSE IF ( M-P .EQ. I ) THEN
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
- CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
- $ X11(I,I+1), LDX11, WORK )
- CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I),
- $ X12(I,I), LDX12, WORK )
- CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
- $ X21(I,I+1), LDX21, WORK )
- CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I),
- $ X22(I,I), LDX22, WORK )
+ IF ( Q .GT. I ) THEN
+ CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
+ $ X11(I,I+1), LDX11, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I),
+ $ X12(I,I), LDX12, WORK )
+ END IF
+ IF ( Q .GT. I ) THEN
+ CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I),
+ $ X22(I,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q ) THEN
CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1),
@@ -444,12 +461,24 @@
$ DNRM2( M-Q-I+1, X12(I,I), LDX12 ) )
*
IF( I .LT. Q ) THEN
- CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
- $ TAUQ1(I) )
+ IF ( Q-I .EQ. 1 ) THEN
+ CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11,
+ $ TAUQ1(I) )
+ ELSE
+ CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
+ $ TAUQ1(I) )
+ END IF
X11(I,I+1) = ONE
END IF
- CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( Q+I-1 .LT. M ) THEN
+ IF ( M-Q .EQ. I ) THEN
+ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
+ END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@@ -458,10 +487,14 @@
CALL DLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
END IF
- CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
- CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X22(I+1,I), LDX22, WORK )
+ IF ( P .GT. I ) THEN
+ CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
+ IF ( M-P .GT. I ) THEN
+ CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
+ END IF
*
END DO
*
@@ -470,12 +503,19 @@
DO I = Q + 1, P
*
CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 )
- CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( I .GE. M-Q ) THEN
+ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
X12(I,I) = ONE
*
- CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ IF ( P. GT. I ) THEN
+ CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL DLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
@@ -487,11 +527,18 @@
DO I = 1, M - P - Q
*
CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 )
- CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
- $ LDX22, TAUQ2(P+I) )
+ IF ( I .EQ. M-P-Q ) THEN
+ CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I),
+ $ LDX22, TAUQ2(P+I) )
+ ELSE
+ CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
+ $ LDX22, TAUQ2(P+I) )
+ END IF
X22(Q+I,P+I) = ONE
- CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
- $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
+ IF ( I .LT. M-P-Q ) THEN
+ CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
+ $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
+ END IF
*
END DO
*
@@ -521,18 +568,31 @@
*
CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
X11(I,I) = ONE
- CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
+ IF ( I .EQ. M-P ) THEN
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
+ $ TAUP2(I) )
+ ELSE
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
$ TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
- CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X11(I+1,I), LDX11, WORK )
- CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X12(I,I), LDX12, WORK )
- CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
- $ X21(I+1,I), LDX21, WORK )
- CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
- $ TAUP2(I), X22(I,I), LDX22, WORK )
+ IF ( Q .GT. I ) THEN
+ CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
+ $ X11(I+1,I), LDX11, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
+ $ TAUP1(I), X12(I,I), LDX12, WORK )
+ END IF
+ IF ( Q .GT. I ) THEN
+ CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
+ $ X21(I+1,I), LDX21, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X22(I,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q ) THEN
CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 )
@@ -548,10 +608,22 @@
$ DNRM2( M-Q-I+1, X12(I,I), 1 ) )
*
IF( I .LT. Q ) THEN
- CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) )
+ IF ( Q-I .EQ. 1) THEN
+ CALL DLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1,
+ $ TAUQ1(I) )
+ ELSE
+ CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1,
+ $ TAUQ1(I) )
+ END IF
X11(I+1,I) = ONE
END IF
- CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
+ IF ( M-Q .GT. I ) THEN
+ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
+ ELSE
+ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1,
+ $ TAUQ2(I) )
+ END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@@ -562,8 +634,10 @@
END IF
CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
$ X12(I,I+1), LDX12, WORK )
- CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I),
- $ X22(I,I+1), LDX22, WORK )
+ IF ( M-P-I .GT. 0 ) THEN
+ CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I),
+ $ X22(I,I+1), LDX22, WORK )
+ END IF
*
END DO
*
@@ -575,8 +649,10 @@
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
X12(I,I) = ONE
*
- CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
+ IF ( P .GT. I ) THEN
+ CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
$ X12(I,I+1), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL DLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I),
$ X22(I,Q+1), LDX22, WORK )
@@ -588,12 +664,16 @@
DO I = 1, M - P - Q
*
CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 )
- CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
- $ TAUQ2(P+I) )
- X22(P+I,Q+I) = ONE
-*
- CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
+ IF ( M-P-Q .EQ. I ) THEN
+ CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1,
+ $ TAUQ2(P+I) )
+ ELSE
+ CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
+ $ TAUQ2(P+I) )
+ CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
$ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK )
+ END IF
+ X22(P+I,Q+I) = ONE
*
END DO
*
diff --git a/lapack-netlib/SRC/dorbdb1.f b/lapack-netlib/SRC/dorbdb1.f
new file mode 100644
index 000000000..b5675f71d
--- /dev/null
+++ b/lapack-netlib/SRC/dorbdb1.f
@@ -0,0 +1,324 @@
+*> \brief \b DORBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines DORBDB2, DORBDB3, and DORBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( X21(I,I), X11(I,I) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S )
+ CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = X21(I,I+1)
+ X21(I,I+1) = ONE
+ CALL DLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL DORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of DORBDB1
+*
+ END
+
diff --git a/lapack-netlib/SRC/dorbdb2.f b/lapack-netlib/SRC/dorbdb2.f
new file mode 100644
index 000000000..3cf82cf40
--- /dev/null
+++ b/lapack-netlib/SRC/dorbdb2.f
@@ -0,0 +1,333 @@
+*> \brief \b DORBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines DORBDB1, DORBDB3, and DORBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION NEGONE, ONE
+ PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
+ END IF
+ CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = X11(I,I)
+ X11(I,I) = ONE
+ CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL DSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL DLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL DLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of DORBDB2
+*
+ END
+
diff --git a/lapack-netlib/SRC/dorbdb3.f b/lapack-netlib/SRC/dorbdb3.f
new file mode 100644
index 000000000..03be504fa
--- /dev/null
+++ b/lapack-netlib/SRC/dorbdb3.f
@@ -0,0 +1,332 @@
+*> \brief \b DORBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB3 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines DORBDB1, DORBDB2, and DORBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
+ END IF
+*
+ CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = X21(I,I)
+ X21(I,I) = ONE
+ CALL DLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ C = SQRT( DNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL DORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL DLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of DORBDB3
+*
+ END
+
diff --git a/lapack-netlib/SRC/dorbdb4.f b/lapack-netlib/SRC/dorbdb4.f
new file mode 100644
index 000000000..8c7236054
--- /dev/null
+++ b/lapack-netlib/SRC/dorbdb4.f
@@ -0,0 +1,378 @@
+*> \brief \b DORBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB4 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines DORBDB1, DORBDB2, and DORBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is DOUBLE PRECISION array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL DORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL DSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL DLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL DLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11,
+ $ WORK(ILARF) )
+ CALL DLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
+ $ LDX21, WORK(ILARF) )
+ ELSE
+ CALL DORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL DSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL DLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = X21(I,I)
+ X21(I,I) = ONE
+ CALL DLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL DLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of DORBDB4
+*
+ END
+
diff --git a/lapack-netlib/SRC/dorbdb5.f b/lapack-netlib/SRC/dorbdb5.f
new file mode 100644
index 000000000..8fd8e6e37
--- /dev/null
+++ b/lapack-netlib/SRC/dorbdb5.f
@@ -0,0 +1,274 @@
+*> \brief \b DORBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB5 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is DOUBLE PRECISION array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is DOUBLE PRECISION array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORBDB6, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( DNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of DORBDB5
+*
+ END
+
diff --git a/lapack-netlib/SRC/dorbdb6.f b/lapack-netlib/SRC/dorbdb6.f
new file mode 100644
index 000000000..59fd863bf
--- /dev/null
+++ b/lapack-netlib/SRC/dorbdb6.f
@@ -0,0 +1,312 @@
+*> \brief \b DORBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB6 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is DOUBLE PRECISION array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is DOUBLE PRECISION array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0,
+ $ REALZERO = 0.0D0 )
+ DOUBLE PRECISION NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of DORBDB6
+*
+ END
+
diff --git a/lapack-netlib/SRC/dorcsd.f b/lapack-netlib/SRC/dorcsd.f
index 927bf664a..d5d48eb9e 100644
--- a/lapack-netlib/SRC/dorcsd.f
+++ b/lapack-netlib/SRC/dorcsd.f
@@ -289,7 +289,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@@ -300,10 +300,10 @@
$ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T,
$ LDV2T, WORK, LWORK, IWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS
@@ -368,9 +368,22 @@
INFO = -8
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -9
- ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR.
- $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN
- INFO = -11
+ ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -11
+ ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN
+ INFO = -11
+ ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN
+ INFO = -13
+ ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -13
+ ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -15
+ ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN
+ INFO = -15
+ ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -17
+ ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -17
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -20
ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN
@@ -427,19 +440,19 @@
ITAUQ1 = ITAUP2 + MAX( 1, M - P )
ITAUQ2 = ITAUQ1 + MAX( 1, Q )
IORGQR = ITAUQ2 + MAX( 1, M - Q )
- CALL DORGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
+ CALL DORGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGQRWORKOPT = INT( WORK(1) )
LORGQRWORKMIN = MAX( 1, M - Q )
IORGLQ = ITAUQ2 + MAX( 1, M - Q )
- CALL DORGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
+ CALL DORGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGLQWORKOPT = INT( WORK(1) )
LORGLQWORKMIN = MAX( 1, M - Q )
IORBDB = ITAUQ2 + MAX( 1, M - Q )
CALL DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
- $ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK,
- $ -1, CHILDINFO )
+ $ X21, LDX21, X22, LDX22, THETA, V1T, U1, U2, V1T,
+ $ V2T, WORK, -1, CHILDINFO )
LORBDBWORKOPT = INT( WORK(1) )
LORBDBWORKMIN = LORBDBWORKOPT
IB11D = ITAUQ2 + MAX( 1, M - Q )
@@ -451,9 +464,10 @@
IB22D = IB21E + MAX( 1, Q - 1 )
IB22E = IB22D + MAX( 1, Q )
IBBCSD = IB22E + MAX( 1, Q - 1 )
- CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0,
- $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0,
- $ 0, 0, 0, 0, 0, 0, 0, WORK, -1, CHILDINFO )
+ CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q,
+ $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T,
+ $ LDV2T, U1, U1, U1, U1, U1, U1, U1, U1, WORK, -1,
+ $ CHILDINFO )
LBBCSDWORKOPT = INT( WORK(1) )
LBBCSDWORKMIN = LBBCSDWORKOPT
LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT,
@@ -514,10 +528,14 @@
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
CALL DLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T )
- CALL DLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
- $ V2T(P+1,P+1), LDV2T )
- CALL DORGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
- $ WORK(IORGLQ), LORGLQWORK, INFO )
+ IF (M-P .GT. Q) Then
+ CALL DLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
+ $ V2T(P+1,P+1), LDV2T )
+ END IF
+ IF (M .GT. Q) THEN
+ CALL DORGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
+ $ WORK(IORGLQ), LORGLQWORK, INFO )
+ END IF
END IF
ELSE
IF( WANTU1 .AND. P .GT. 0 ) THEN
diff --git a/lapack-netlib/SRC/dorcsd2by1.f b/lapack-netlib/SRC/dorcsd2by1.f
new file mode 100644
index 000000000..f3ac4e546
--- /dev/null
+++ b/lapack-netlib/SRC/dorcsd2by1.f
@@ -0,0 +1,715 @@
+*> \brief \b DORCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORCSD2BY1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION THETA(*)
+* DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*> Purpose:
+*> ========
+*>
+*> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is DOUBLE PRECISION array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is DOUBLE PRECISION array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is DOUBLE PRECISION array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \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.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: DBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* -- LAPACK computational routine (3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION THETA(*)
+ DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBBCSD, DCOPY, DLACPY, DLAPMR, DLAPMT, DORBDB1,
+ $ DORBDB2, DORBDB3, DORBDB4, DORGLQ, DORGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-------------------------------------------------------|
+* | LWORKOPT (1) |
+* |-------------------------------------------------------|
+* | PHI (MAX(1,R-1)) |
+* |-------------------------------------------------------|
+* | TAUP1 (MAX(1,P)) | B11D (R) |
+* | TAUP2 (MAX(1,M-P)) | B11E (R-1) |
+* | TAUQ1 (MAX(1,Q)) | B12D (R) |
+* |-----------------------------------------| B12E (R-1) |
+* | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R) |
+* | | | | B21E (R-1) |
+* | | | | B22D (R) |
+* | | | | B22E (R-1) |
+* | | | | DBBCSD WORK |
+* |-------------------------------------------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + MAX( 1, R )
+ IB12D = IB11E + MAX( 1, R - 1 )
+ IB12E = IB12D + MAX( 1, R )
+ IB21D = IB12E + MAX( 1, R - 1 )
+ IB21E = IB21D + MAX( 1, R )
+ IB22D = IB21E + MAX( 1, R - 1 )
+ IB22E = IB22D + MAX( 1, R )
+ IBBCSD = IB22E + MAX( 1, R - 1 )
+ ITAUP1 = IPHI + MAX( 1, R-1 )
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE
+ CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL DORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ END IF
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1,
+ $ IBBCSD+LBBCSD-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1,
+ $ IBBCSD+LBBCSD-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL DLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL DLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL DLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL DLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL DLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1,
+ $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL DLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL DLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL DCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL DLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL DORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL DCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL DLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL DLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL DLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL DLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL DORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL DLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL DLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DORCSD2BY1
+*
+ END
+
diff --git a/lapack-netlib/SRC/dstemr.f b/lapack-netlib/SRC/dstemr.f
index 5930465e3..8967c18fc 100644
--- a/lapack-netlib/SRC/dstemr.f
+++ b/lapack-netlib/SRC/dstemr.f
@@ -294,7 +294,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@@ -312,10 +312,10 @@
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
@@ -391,6 +391,7 @@
WU = ZERO
IIL = 0
IIU = 0
+ NSPLIT = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
diff --git a/lapack-netlib/SRC/dsycon_rook.f b/lapack-netlib/SRC/dsycon_rook.f
new file mode 100644
index 000000000..2b8b6f901
--- /dev/null
+++ b/lapack-netlib/SRC/dsycon_rook.f
@@ -0,0 +1,258 @@
+*> \brief \b DSYCON_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYCON_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYCON_ROOK estimates the reciprocal of the condition number (in the
+*> 1-norm) of a real symmetric matrix A using the factorization
+*> A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is DOUBLE PRECISION
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is DOUBLE PRECISION
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DSYTRS_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYCON_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL DSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of DSYCON_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/dsysv_rook.f b/lapack-netlib/SRC/dsysv_rook.f
new file mode 100644
index 000000000..4db3a98ef
--- /dev/null
+++ b/lapack-netlib/SRC/dsysv_rook.f
@@ -0,0 +1,293 @@
+*> \brief DSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYSV_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+* LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYSV_ROOK computes the solution to a real system of linear
+*> equations
+*> A * X = B,
+*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*> matrices.
+*>
+*> The diagonal pivoting method is used to factor A as
+*> A = U * D * U**T, if UPLO = 'U', or
+*> A = L * D * L**T, if UPLO = 'L',
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> DSYTRF_ROOK is called to compute the factorization of a real
+*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method.
+*>
+*> The factored form of A is then used to solve the system
+*> of equations A * X = B by calling DSYTRS_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order of the
+*> matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, if INFO = 0, the block diagonal matrix D and the
+*> multipliers used to obtain the factor U or L from the
+*> factorization A = U*D*U**T or A = L*D*L**T as computed by
+*> DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by DSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \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 length of WORK. LWORK >= 1, and for best performance
+*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+*> DSYTRF_ROOK.
+*>
+*> TRS will be done with Level 2 BLAS
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, so the solution could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup doubleSYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, DSYTRF_ROOK, DSYTRS_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYSV_ROOK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**T or A = L*D*L**T.
+*
+ CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+* Solve with TRS_ROOK ( Use Level 2 BLAS)
+*
+ CALL DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYSV_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/dsytf2.f b/lapack-netlib/SRC/dsytf2.f
index 23d8889d4..27a676b84 100644
--- a/lapack-netlib/SRC/dsytf2.f
+++ b/lapack-netlib/SRC/dsytf2.f
@@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup doubleSYcomputational
*
@@ -185,10 +194,10 @@
* =====================================================================
SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -268,7 +277,8 @@
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, A( 1, K ), 1 )
@@ -279,7 +289,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -436,7 +447,8 @@
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
@@ -447,7 +459,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
diff --git a/lapack-netlib/SRC/dsytf2_rook.f b/lapack-netlib/SRC/dsytf2_rook.f
new file mode 100644
index 000000000..237c9984c
--- /dev/null
+++ b/lapack-netlib/SRC/dsytf2_rook.f
@@ -0,0 +1,813 @@
+*> \brief \b DSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTF2_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYTF2_ROOK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, U**T is the transpose of U, and D is symmetric and
+*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ ROWMAX, DTEMP, T, WK, WKM1, WKP1, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSWAP, DSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTF2_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IDAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ DTEMP = ABS( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL DSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL DSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL DSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ DTEMP = ABS( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of DSYTF2_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/dsytrf_rook.f b/lapack-netlib/SRC/dsytrf_rook.f
new file mode 100644
index 000000000..81264872a
--- /dev/null
+++ b/lapack-netlib/SRC/dsytrf_rook.f
@@ -0,0 +1,393 @@
+*> \brief \b DSYTRF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTRF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYTRF_ROOK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*> The form of the factorization is
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASYF_ROOK, DSYTF2_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'DSYTRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRF_ROOK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF_ROOK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by DLASYF_ROOK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL DLASYF_ROOK( UPLO, K, NB, KB, A, LDA,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL DSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by DLASYF_ROOK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL DLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL DSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
+ $ IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DSYTRF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/dsytri_rook.f b/lapack-netlib/SRC/dsytri_rook.f
new file mode 100644
index 000000000..f5b42a297
--- /dev/null
+++ b/lapack-netlib/SRC/dsytri_rook.f
@@ -0,0 +1,450 @@
+*> \brief \b DSYTRI_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTRI_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYTRI_ROOK computes the inverse of a real symmetric
+*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
+*> computed by DSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the block diagonal matrix D and the multipliers
+*> used to obtain the factor U or L as computed by DSYTRF_ROOK.
+*>
+*> On exit, if INFO = 0, the (symmetric) inverse of the original
+*> matrix. If UPLO = 'U', the upper triangular part of the
+*> inverse is formed and the part of A below the diagonal is not
+*> referenced; if UPLO = 'L' the lower triangular part of the
+*> inverse is formed and the part of A above the diagonal is
+*> not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (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, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KP, KSTEP
+ DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRI_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K+1 ) )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K+1 with -IPIV(K) and
+* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+*
+ K = K + 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K + 1
+ GO TO 30
+ 40 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 50 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K-1 ) )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K-1 with -IPIV(K) and
+* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+*
+ K = K - 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K - 1
+ GO TO 50
+ 60 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSYTRI_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/dsytrs_rook.f b/lapack-netlib/SRC/dsytrs_rook.f
new file mode 100644
index 000000000..b1cb9b152
--- /dev/null
+++ b/lapack-netlib/SRC/dsytrs_rook.f
@@ -0,0 +1,484 @@
+*> \brief \b DSYTRS_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTRS_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYTRS_ROOK solves a system of linear equations A*X = B with
+*> a real symmetric matrix A using the factorization A = U*D*U**T or
+*> A = L*D*L**T computed by DSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRS_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.GT.2 ) THEN
+ CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U**T *X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U**T(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.GT.1 )
+ $ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / AKM1K
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L**T *X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L**T(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSYTRS_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/dtpmqrt.f b/lapack-netlib/SRC/dtpmqrt.f
index baeffa0f7..b8bf7ce97 100644
--- a/lapack-netlib/SRC/dtpmqrt.f
+++ b/lapack-netlib/SRC/dtpmqrt.f
@@ -175,7 +175,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@@ -216,10 +216,10 @@
SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
$ A, LDA, B, LDB, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -235,7 +235,7 @@
* ..
* .. Local Scalars ..
LOGICAL LEFT, RIGHT, TRAN, NOTRAN
- INTEGER I, IB, MB, LB, KF, Q
+ INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -257,10 +257,12 @@
TRAN = LSAME( TRANS, 'T' )
NOTRAN = LSAME( TRANS, 'N' )
*
- IF( LEFT ) THEN
- Q = M
+ IF ( LEFT ) THEN
+ LDVQ = MAX( 1, M )
+ LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
- Q = N
+ LDVQ = MAX( 1, N )
+ LDAQ = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
INFO = -1
@@ -274,13 +276,13 @@
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
INFO = -6
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
- ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
+ ELSE IF( LDV.LT.LDVQ ) THEN
INFO = -9
ELSE IF( LDT.LT.NB ) THEN
INFO = -11
- ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ ELSE IF( LDA.LT.LDAQ ) THEN
INFO = -13
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -15
diff --git a/lapack-netlib/SRC/dtpqrt.f b/lapack-netlib/SRC/dtpqrt.f
index 95f6fde2d..c8f2e14c1 100644
--- a/lapack-netlib/SRC/dtpqrt.f
+++ b/lapack-netlib/SRC/dtpqrt.f
@@ -132,7 +132,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@@ -189,10 +189,10 @@
SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK,
$ INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDT, N, M, L, NB
@@ -219,9 +219,9 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
INFO = -3
- ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
diff --git a/lapack-netlib/SRC/ilaver.f b/lapack-netlib/SRC/ilaver.f
index a00cbbccf..0f1ee5d87 100644
--- a/lapack-netlib/SRC/ilaver.f
+++ b/lapack-netlib/SRC/ilaver.f
@@ -48,18 +48,18 @@
* =====================================================================
SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* =====================================================================
*
INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
* =====================================================================
VERS_MAJOR = 3
- VERS_MINOR = 4
- VERS_PATCH = 2
+ VERS_MINOR = 5
+ VERS_PATCH = 0
* =====================================================================
*
RETURN
diff --git a/lapack-netlib/SRC/sbbcsd.f b/lapack-netlib/SRC/sbbcsd.f
index 162d5336f..759d331f6 100644
--- a/lapack-netlib/SRC/sbbcsd.f
+++ b/lapack-netlib/SRC/sbbcsd.f
@@ -322,7 +322,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@@ -332,10 +332,10 @@
$ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E,
$ B22D, B22E, WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
@@ -358,8 +358,8 @@
PARAMETER ( HUNDRED = 100.0E0, MEIGHTH = -0.125E0,
$ ONE = 1.0E0, PIOVER2 = 1.57079632679489662E0,
$ TEN = 10.0E0, ZERO = 0.0E0 )
- REAL NEGONECOMPLEX
- PARAMETER ( NEGONECOMPLEX = -1.0E0 )
+ REAL NEGONE
+ PARAMETER ( NEGONE = -1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12,
@@ -477,7 +477,10 @@
* Initial deflation
*
IMAX = Q
- DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) )
+ DO WHILE( IMAX .GT. 1 )
+ IF( PHI(IMAX-1) .NE. ZERO ) THEN
+ EXIT
+ END IF
IMAX = IMAX - 1
END DO
IMIN = IMAX - 1
@@ -939,9 +942,9 @@
B21D(IMAX) = -B21D(IMAX)
IF( WANTV1T ) THEN
IF( COLMAJOR ) THEN
- CALL SSCAL( Q, NEGONECOMPLEX, V1T(IMAX,1), LDV1T )
+ CALL SSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T )
ELSE
- CALL SSCAL( Q, NEGONECOMPLEX, V1T(1,IMAX), 1 )
+ CALL SSCAL( Q, NEGONE, V1T(1,IMAX), 1 )
END IF
END IF
END IF
@@ -962,9 +965,9 @@
B12D(IMAX) = -B12D(IMAX)
IF( WANTU1 ) THEN
IF( COLMAJOR ) THEN
- CALL SSCAL( P, NEGONECOMPLEX, U1(1,IMAX), 1 )
+ CALL SSCAL( P, NEGONE, U1(1,IMAX), 1 )
ELSE
- CALL SSCAL( P, NEGONECOMPLEX, U1(IMAX,1), LDU1 )
+ CALL SSCAL( P, NEGONE, U1(IMAX,1), LDU1 )
END IF
END IF
END IF
@@ -972,9 +975,9 @@
B22D(IMAX) = -B22D(IMAX)
IF( WANTU2 ) THEN
IF( COLMAJOR ) THEN
- CALL SSCAL( M-P, NEGONECOMPLEX, U2(1,IMAX), 1 )
+ CALL SSCAL( M-P, NEGONE, U2(1,IMAX), 1 )
ELSE
- CALL SSCAL( M-P, NEGONECOMPLEX, U2(IMAX,1), LDU2 )
+ CALL SSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 )
END IF
END IF
END IF
@@ -984,9 +987,9 @@
IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN
IF( WANTV2T ) THEN
IF( COLMAJOR ) THEN
- CALL SSCAL( M-Q, NEGONECOMPLEX, V2T(IMAX,1), LDV2T )
+ CALL SSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T )
ELSE
- CALL SSCAL( M-Q, NEGONECOMPLEX, V2T(1,IMAX), 1 )
+ CALL SSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 )
END IF
END IF
END IF
diff --git a/lapack-netlib/SRC/sgebal.f b/lapack-netlib/SRC/sgebal.f
index 853ff20e2..6c5d1482e 100644
--- a/lapack-netlib/SRC/sgebal.f
+++ b/lapack-netlib/SRC/sgebal.f
@@ -121,7 +121,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup realGEcomputational
*
@@ -160,10 +160,10 @@
* =====================================================================
SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
@@ -192,8 +192,8 @@
* .. External Functions ..
LOGICAL SISNAN, LSAME
INTEGER ISAMAX
- REAL SLAMCH
- EXTERNAL SISNAN, LSAME, ISAMAX, SLAMCH
+ REAL SLAMCH, SNRM2
+ EXTERNAL SISNAN, LSAME, ISAMAX, SLAMCH, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSWAP, XERBLA
@@ -316,15 +316,9 @@
NOCONV = .FALSE.
*
DO 200 I = K, L
- C = ZERO
- R = ZERO
-*
- DO 150 J = K, L
- IF( J.EQ.I )
- $ GO TO 150
- C = C + ABS( A( J, I ) )
- R = R + ABS( A( I, J ) )
- 150 CONTINUE
+*
+ C = SNRM2( L-K+1, A( K, I ), 1 )
+ R = SNRM2( L-K+1, A( I, K ), LDA )
ICA = ISAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = ISAMAX( N-K+1, A( I, K ), LDA )
diff --git a/lapack-netlib/SRC/sgemqrt.f b/lapack-netlib/SRC/sgemqrt.f
index 443c9d1e8..3b29f765f 100644
--- a/lapack-netlib/SRC/sgemqrt.f
+++ b/lapack-netlib/SRC/sgemqrt.f
@@ -160,7 +160,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup realGEcomputational
*
@@ -168,10 +168,10 @@
SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -225,7 +225,7 @@
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN
INFO = -5
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN
INFO = -6
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
INFO = -8
diff --git a/lapack-netlib/SRC/sgeqrt.f b/lapack-netlib/SRC/sgeqrt.f
index 0efc07b86..e995212a3 100644
--- a/lapack-netlib/SRC/sgeqrt.f
+++ b/lapack-netlib/SRC/sgeqrt.f
@@ -108,7 +108,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup realGEcomputational
*
@@ -141,10 +141,10 @@
* =====================================================================
SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDT, M, N, NB
@@ -173,7 +173,7 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN
+ ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
diff --git a/lapack-netlib/SRC/sgesdd.f b/lapack-netlib/SRC/sgesdd.f
index 821767aaa..746fd3bab 100644
--- a/lapack-netlib/SRC/sgesdd.f
+++ b/lapack-netlib/SRC/sgesdd.f
@@ -175,8 +175,7 @@
*> LWORK >= 3*min(M,N) +
*> max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
*> If JOBZ = 'S' or 'A'
-*> LWORK >= 3*min(M,N) +
-*> max(max(M,N),4*min(M,N)*min(M,N)+3*min(M,N)+max(M,N)).
+*> LWORK >= min(M,N)*(6+4*min(M,N))+max(M,N)
*> For good performance, LWORK should generally be larger.
*> If LWORK = -1 but other input arguments are legal, WORK(1)
*> returns the optimal LWORK.
@@ -203,7 +202,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup realGEsing
*
@@ -217,10 +216,10 @@
SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
-* -- LAPACK driver routine (version 3.4.2) --
+* -- LAPACK driver routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ
diff --git a/lapack-netlib/SRC/sgetc2.f b/lapack-netlib/SRC/sgetc2.f
index 7e9d48507..3c3880d4e 100644
--- a/lapack-netlib/SRC/sgetc2.f
+++ b/lapack-netlib/SRC/sgetc2.f
@@ -98,7 +98,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup realGEauxiliary
*
@@ -111,10 +111,10 @@
* =====================================================================
SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
@@ -203,6 +203,11 @@
INFO = N
A( N, N ) = SMIN
END IF
+*
+* Set last pivots to N
+*
+ IPIV( N ) = N
+ JPIV( N ) = N
*
RETURN
*
diff --git a/lapack-netlib/SRC/shgeqz.f b/lapack-netlib/SRC/shgeqz.f
index 4bd1a1de6..254e65fcf 100644
--- a/lapack-netlib/SRC/shgeqz.f
+++ b/lapack-netlib/SRC/shgeqz.f
@@ -282,7 +282,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup realGEcomputational
*
@@ -304,10 +304,10 @@
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
$ LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
@@ -739,9 +739,9 @@
* Exceptional shift. Chosen for no particularly good reason.
* (Single shift only.)
*
- IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT.
+ IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST, ILAST-1 ) ).LT.
$ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN
- ESHIFT = ESHIFT + H( ILAST, ILAST-1 ) /
+ ESHIFT = H( ILAST, ILAST-1 ) /
$ T( ILAST-1, ILAST-1 )
ELSE
ESHIFT = ESHIFT + ONE / ( SAFMIN*REAL( MAXIT ) )
@@ -759,6 +759,16 @@
$ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
$ S2, WR, WR2, WI )
*
+ IF ( ABS( (WR/S1)*T( ILAST, ILAST ) - H( ILAST, ILAST ) )
+ $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST )
+ $ - H( ILAST, ILAST ) ) ) THEN
+ TEMP = WR
+ WR = WR2
+ WR2 = TEMP
+ TEMP = S1
+ S1 = S2
+ S2 = TEMP
+ END IF
TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
IF( WI.NE.ZERO )
$ GO TO 200
diff --git a/lapack-netlib/SRC/shsein.f b/lapack-netlib/SRC/shsein.f
index 0c69e2cf8..ffae353e0 100644
--- a/lapack-netlib/SRC/shsein.f
+++ b/lapack-netlib/SRC/shsein.f
@@ -108,6 +108,7 @@
*> \verbatim
*> H is REAL array, dimension (LDH,N)
*> The upper Hessenberg matrix H.
+*> If a NaN is detected in H, the routine will return with INFO=-6.
*> \endverbatim
*>
*> \param[in] LDH
@@ -243,7 +244,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@@ -262,10 +263,10 @@
$ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
$ IFAILR, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
@@ -291,9 +292,9 @@
$ WKR
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, SISNAN
REAL SLAMCH, SLANHS
- EXTERNAL LSAME, SLAMCH, SLANHS
+ EXTERNAL LSAME, SLAMCH, SLANHS, SISNAN
* ..
* .. External Subroutines ..
EXTERNAL SLAEIN, XERBLA
@@ -423,7 +424,10 @@
* has not ben computed before.
*
HNORM = SLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
- IF( HNORM.GT.ZERO ) THEN
+ IF( SISNAN( HNORM ) ) THEN
+ INFO = -6
+ RETURN
+ ELSE IF( HNORM.GT.ZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
diff --git a/lapack-netlib/SRC/sladiv.f b/lapack-netlib/SRC/sladiv.f
index eace5c728..6d26da20c 100644
--- a/lapack-netlib/SRC/sladiv.f
+++ b/lapack-netlib/SRC/sladiv.f
@@ -36,8 +36,9 @@
*> p + i*q = ---------
*> c + i*d
*>
-*> The algorithm is due to Robert L. Smith and can be found
-*> in D. Knuth, The art of Computer Programming, Vol.2, p.195
+*> The algorithm is due to Michael Baudin and Robert L. Smith
+*> and can be found in the paper
+*> "A Robust Complex Division in Scilab"
*> \endverbatim
*
* Arguments:
@@ -83,17 +84,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date January 2013
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* January 2013
*
* .. Scalar Arguments ..
REAL A, B, C, D, P, Q
@@ -101,24 +102,148 @@
*
* =====================================================================
*
+* .. Parameters ..
+ REAL BS
+ PARAMETER ( BS = 2.0E0 )
+ REAL HALF
+ PARAMETER ( HALF = 0.5E0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E0 )
+*
* .. Local Scalars ..
- REAL E, F
+ REAL AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLADIV1
* ..
* .. Intrinsic Functions ..
- INTRINSIC ABS
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ AA = A
+ BB = B
+ CC = C
+ DD = D
+ AB = MAX( ABS(A), ABS(B) )
+ CD = MAX( ABS(C), ABS(D) )
+ S = 1.0E0
+
+ OV = SLAMCH( 'Overflow threshold' )
+ UN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Epsilon' )
+ BE = BS / (EPS*EPS)
+
+ IF( AB >= HALF*OV ) THEN
+ AA = HALF * AA
+ BB = HALF * BB
+ S = TWO * S
+ END IF
+ IF( CD >= HALF*OV ) THEN
+ CC = HALF * CC
+ DD = HALF * DD
+ S = HALF * S
+ END IF
+ IF( AB <= UN*BS/EPS ) THEN
+ AA = AA * BE
+ BB = BB * BE
+ S = S / BE
+ END IF
+ IF( CD <= UN*BS/EPS ) THEN
+ CC = CC * BE
+ DD = DD * BE
+ S = S * BE
+ END IF
+ IF( ABS( D ).LE.ABS( C ) ) THEN
+ CALL SLADIV1(AA, BB, CC, DD, P, Q)
+ ELSE
+ CALL SLADIV1(BB, AA, DD, CC, P, Q)
+ Q = -Q
+ END IF
+ P = P * S
+ Q = Q * S
+*
+ RETURN
+*
+* End of SLADIV
+*
+ END
+
+
+
+ SUBROUTINE SLADIV1( A, B, C, D, P, Q )
+*
+* -- LAPACK auxiliary routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* January 2013
+*
+* .. Scalar Arguments ..
+ REAL A, B, C, D, P, Q
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+*
+* .. Local Scalars ..
+ REAL R, T
+* ..
+* .. External Functions ..
+ REAL SLADIV2
+ EXTERNAL SLADIV2
+* ..
+* .. Executable Statements ..
+*
+ R = D / C
+ T = ONE / (C + D * R)
+ P = SLADIV2(A, B, C, D, R, T)
+ A = -A
+ Q = SLADIV2(B, A, C, D, R, T)
+*
+ RETURN
+*
+* End of SLADIV1
+*
+ END
+
+ REAL FUNCTION SLADIV2( A, B, C, D, R, T )
+*
+* -- LAPACK auxiliary routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* January 2013
+*
+* .. Scalar Arguments ..
+ REAL A, B, C, D, R, T
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+*
+* .. Local Scalars ..
+ REAL BR
* ..
* .. Executable Statements ..
*
- IF( ABS( D ).LT.ABS( C ) ) THEN
- E = D / C
- F = C + D*E
- P = ( A+B*E ) / F
- Q = ( B-A*E ) / F
+ IF( R.NE.ZERO ) THEN
+ BR = B * R
+ if( BR.NE.ZERO ) THEN
+ SLADIV2 = (A + BR) * T
+ ELSE
+ SLADIV2 = A * T + (B * T) * R
+ END IF
ELSE
- E = C / D
- F = D + C*E
- P = ( B+A*E ) / F
- Q = ( -A+B*E ) / F
+ SLADIV2 = (A + D * (B / C)) * T
END IF
*
RETURN
diff --git a/lapack-netlib/SRC/slarfb.f b/lapack-netlib/SRC/slarfb.f
index 7694801e0..78b121d24 100644
--- a/lapack-netlib/SRC/slarfb.f
+++ b/lapack-netlib/SRC/slarfb.f
@@ -159,7 +159,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date June 2013
*
*> \ingroup realOTHERauxiliary
*
@@ -195,10 +195,10 @@
SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@@ -217,12 +217,11 @@
* ..
* .. Local Scalars ..
CHARACTER TRANST
- INTEGER I, J, LASTV, LASTC
+ INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
- INTEGER ILASLR, ILASLC
- EXTERNAL LSAME, ILASLR, ILASLC
+ EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, STRMM
@@ -252,58 +251,53 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
- LASTC = ILASLC( LASTV, N, C, LDC )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C1**T
*
DO 10 J = 1, K
- CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
- CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
-* W := W + C2**T *V2
+* W := W + C2**T * V2
*
- CALL SGEMM( 'Transpose', 'No transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
- IF( LASTV.GT.K ) THEN
+ IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W**T
*
- CALL SGEMM( 'No transpose', 'Transpose',
- $ LASTV-K, LASTC, K,
- $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
- $ C( K+1, 1 ), LDC )
+ CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**T
*
- CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 30 J = 1, K
- DO 20 I = 1, LASTC
+ DO 20 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
20 CONTINUE
30 CONTINUE
@@ -311,58 +305,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
- LASTC = ILASLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
- CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
- CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
- CALL SGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**T
*
- CALL SGEMM( 'No transpose', 'Transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
- $ C( 1, K+1 ), LDC )
+ CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**T
*
- CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
- DO 50 I = 1, LASTC
+ DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
@@ -378,36 +367,31 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTC = ILASLC( M, N, C, LDC )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C2**T
*
DO 70 J = 1, K
- CALL SCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
+ CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
- CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
-* W := W + C1**T*V1
+* W := W + C1**T * V1
*
- CALL SGEMM( 'Transpose', 'No transpose',
- $ LASTC, K, M-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
@@ -415,57 +399,51 @@
*
* C1 := C1 - V1 * W**T
*
- CALL SGEMM( 'No transpose', 'Transpose',
- $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
- $ ONE, C, LDC )
+ CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
- CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 90 J = 1, K
- DO 80 I = 1, LASTC
- C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J)
+ DO 80 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
-* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTC = ILASLR( M, N, C, LDC )
+* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
- CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+ CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
- CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
- CALL SGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, N-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
@@ -473,22 +451,20 @@
*
* C1 := C1 - W * V1**T
*
- CALL SGEMM( 'No transpose', 'Transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
- CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
- DO 110 I = 1, LASTC
- C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J)
+ DO 110 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
@@ -505,58 +481,53 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
- LASTC = ILASLC( LASTV, N, C, LDC )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C1**T
*
DO 130 J = 1, K
- CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**T
*
- CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
-* W := W + C2**T*V2**T
+* W := W + C2**T * V2**T
*
- CALL SGEMM( 'Transpose', 'Transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+ $ WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
- IF( LASTV.GT.K ) THEN
+ IF( M.GT.K ) THEN
*
* C2 := C2 - V2**T * W**T
*
- CALL SGEMM( 'Transpose', 'Transpose',
- $ LASTV-K, LASTC, K,
- $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
- $ ONE, C( K+1, 1 ), LDC )
+ CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
- CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 150 J = 1, K
- DO 140 I = 1, LASTC
+ DO 140 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
140 CONTINUE
150 CONTINUE
@@ -564,58 +535,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
- LASTC = ILASLR( M, LASTV, C, LDC )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
- CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**T
*
- CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2**T
*
- CALL SGEMM( 'No transpose', 'Transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
- CALL SGEMM( 'No transpose', 'No transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
- $ ONE, C( 1, K+1 ), LDC )
+ CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
- CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
- DO 170 I = 1, LASTC
+ DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
@@ -631,36 +597,31 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
-*
- LASTC = ILASLC( M, N, C, LDC )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C2**T
*
DO 190 J = 1, K
- CALL SCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
+ CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**T
*
- CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**T * V1**T
*
- CALL SGEMM( 'Transpose', 'Transpose',
- $ LASTC, K, M-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
- CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
@@ -668,58 +629,51 @@
*
* C1 := C1 - V1**T * W**T
*
- CALL SGEMM( 'Transpose', 'Transpose',
- $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
- $ ONE, C, LDC )
+ CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 210 J = 1, K
- DO 200 I = 1, LASTC
- C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J)
+ DO 200 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
-*
- LASTC = ILASLR( M, N, C, LDC )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
- CALL SCOPY( LASTC, C( 1, N-K+J ), 1,
- $ WORK( 1, J ), 1 )
+ CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**T
*
- CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**T
*
- CALL SGEMM( 'No transpose', 'Transpose',
- $ LASTC, K, N-K, ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
- CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
@@ -727,21 +681,19 @@
*
* C1 := C1 - W * V1
*
- CALL SGEMM( 'No transpose', 'No transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
- DO 230 I = 1, LASTC
+ DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
diff --git a/lapack-netlib/SRC/slasd4.f b/lapack-netlib/SRC/slasd4.f
index bf0f2cf3e..0c5daca03 100644
--- a/lapack-netlib/SRC/slasd4.f
+++ b/lapack-netlib/SRC/slasd4.f
@@ -140,7 +140,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup auxOTHERauxiliary
*
@@ -153,10 +153,10 @@
* =====================================================================
SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
diff --git a/lapack-netlib/SRC/slasyf.f b/lapack-netlib/SRC/slasyf.f
index 20c8ffaec..58dace2ee 100644
--- a/lapack-netlib/SRC/slasyf.f
+++ b/lapack-netlib/SRC/slasyf.f
@@ -1,25 +1,25 @@
-*> \brief \b SLASYF computes a partial factorization of a real symmetric matrix, using the diagonal pivoting method.
+*> \brief \b SLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download SLASYF + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download SLASYF + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
@@ -28,7 +28,7 @@
* INTEGER IPIV( * )
* REAL A( LDA, * ), W( LDW, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -109,16 +109,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If UPLO = 'U', only the last KB elements of IPIV are set;
-*> if UPLO = 'L', only the first KB elements are set.
*>
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@@ -144,22 +154,32 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup realSYcomputational
*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*> \endverbatim
+*
* =====================================================================
SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -237,7 +257,8 @@
ABSAKK = ABS( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ISAMAX( K-1, W( 1, KW ), 1 )
@@ -248,7 +269,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -293,7 +314,7 @@
*
KP = IMAX
*
-* copy column KW-1 of W to column KW
+* copy column KW-1 of W to column KW of W
*
CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
@@ -305,60 +326,118 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
KKW = NB + KK - N
*
-* Updated column KP is already stored in column KKW of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ A( KP, KP ) = A( KK, KK )
+ CALL SCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
- CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( KP.GT.1 )
+ $ CALL SCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
-* Interchange rows KK and KP in last KK columns of A and W
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
*
- CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ IF( K.LT.N )
+ $ CALL SSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
-* 1-by-1 pivot block D(k): column KW of W now holds
+* 1-by-1 pivot block D(k): column kw of W now holds
*
-* W(k) = U(k)*D(k)
+* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
-* Store U(k) in column k of A
+* Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored.
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = ONE / A( K, K )
CALL SSCAL( K-1, R1, A( 1, K ), 1 )
+*
ELSE
*
-* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
-* hold
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
-* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
+*
+* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored.
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
-* Store U(k) and U(k-1) in columns k and k-1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
@@ -370,7 +449,9 @@
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -414,20 +495,28 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
-* in columns k+1:n
+* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J + 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
J = J + 1
- END IF
- J = J + 1
- IF( JP.NE.JJ .AND. J.LE.N )
- $ CALL SSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
- IF( J.LE.N )
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL SSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
@@ -464,7 +553,8 @@
ABSAKK = ABS( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 )
@@ -475,7 +565,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -518,7 +608,7 @@
*
KP = IMAX
*
-* copy column K+1 of W to column K
+* copy column K+1 of W to column K of W
*
CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
@@ -530,22 +620,36 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
-* Updated column KP is already stored in column KK of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
- CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+ A( KP, KP ) = A( KK, KK )
+ CALL SCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ IF( KP.LT.N )
+ $ CALL SCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
-* Interchange rows KK and KP in first KK columns of A and W
+* Interchange rows KK and KP in first K-1 columns of A
+* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
*
- CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ IF( K.GT.1 )
+ $ CALL SSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@@ -553,17 +657,23 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
-* W(k) = L(k)*D(k)
+* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
-* Store L(k) in column k of A
+* Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = ONE / A( K, K )
CALL SSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
+*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@@ -572,16 +682,52 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
+*
+* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored)
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
-* Store L(k) and L(k+1) in columns k and k+1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
@@ -593,7 +739,9 @@
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -638,20 +786,28 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
-* in columns 1:k-1
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J - 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
J = J - 1
- END IF
- J = J - 1
- IF( JP.NE.JJ .AND. J.GE.1 )
- $ CALL SSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
- IF( J.GE.1 )
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL SSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
diff --git a/lapack-netlib/SRC/slasyf_rook.f b/lapack-netlib/SRC/slasyf_rook.f
new file mode 100644
index 000000000..65bb2ad9d
--- /dev/null
+++ b/lapack-netlib/SRC/slasyf_rook.f
@@ -0,0 +1,892 @@
+*> \brief \b SLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SLASYF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SLASYF_ROOK computes a partial factorization of a real symmetric
+*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> SLASYF_ROOK is an auxiliary routine called by SSYTRF_ROOK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*> On exit, A contains details of the partial factorization.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is REAL array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup realSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK,
+ $ KW, KKW, KP, KSTEP, P, II
+
+ REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ STEMP, R1, ROWMAX, T, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ISAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = ABS( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL SCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL SGEMV( 'No transpose', K, N-K, -ONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ ONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ISAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = ABS( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ISAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ STEMP = ABS( W( ITEMP, KW-1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL SCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL SCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL SSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL SSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL SSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = ONE / ( D11*D22-ONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL SGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL SGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ ONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in columns k+1:n
+*
+ J = K + 1
+ 60 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J + 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J + 1
+ IF( JP2.NE.JJ .AND. J.LE.N )
+ $ CALL SSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
+ JJ = J - 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL SSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LE.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = ABS( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ ONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ISAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = ABS( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ISAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ STEMP = ABS( W( ITEMP, K+1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL SCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL SCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL SSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL SSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL SSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL SGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
+ $ ONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* in columns 1:k-1
+*
+ J = K - 1
+ 120 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J - 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J - 1
+ IF( JP2.NE.JJ .AND. J.GE.1 )
+ $ CALL SSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
+ JJ = J + 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL SSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GE.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of SLASYF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/sorbdb.f b/lapack-netlib/SRC/sorbdb.f
index 433b3c035..f001da63d 100644
--- a/lapack-netlib/SRC/sorbdb.f
+++ b/lapack-netlib/SRC/sorbdb.f
@@ -255,7 +255,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@@ -287,10 +287,10 @@
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIGNS, TRANS
@@ -415,19 +415,36 @@
THETA(I) = ATAN2( SNRM2( M-P-I+1, X21(I,I), 1 ),
$ SNRM2( P-I+1, X11(I,I), 1 ) )
*
- CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( P .GT. I ) THEN
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ ELSE IF( P .EQ. I ) THEN
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
+ END IF
X11(I,I) = ONE
- CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF ( M-P .GT. I ) THEN
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
+ $ TAUP2(I) )
+ ELSE IF ( M-P .EQ. I ) THEN
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
- CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
- $ X11(I,I+1), LDX11, WORK )
- CALL SLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I),
- $ X12(I,I), LDX12, WORK )
- CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
- $ X21(I,I+1), LDX21, WORK )
- CALL SLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I),
- $ X22(I,I), LDX22, WORK )
+ IF ( Q .GT. I ) THEN
+ CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
+ $ X11(I,I+1), LDX11, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL SLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I),
+ $ X12(I,I), LDX12, WORK )
+ END IF
+ IF ( Q .GT. I ) THEN
+ CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL SLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I),
+ $ X22(I,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q ) THEN
CALL SSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1),
@@ -444,12 +461,24 @@
$ SNRM2( M-Q-I+1, X12(I,I), LDX12 ) )
*
IF( I .LT. Q ) THEN
- CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
- $ TAUQ1(I) )
+ IF ( Q-I .EQ. 1 ) THEN
+ CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11,
+ $ TAUQ1(I) )
+ ELSE
+ CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
+ $ TAUQ1(I) )
+ END IF
X11(I,I+1) = ONE
END IF
- CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( Q+I-1 .LT. M ) THEN
+ IF ( M-Q .EQ. I ) THEN
+ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
+ END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@@ -458,10 +487,14 @@
CALL SLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
END IF
- CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
- CALL SLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X22(I+1,I), LDX22, WORK )
+ IF ( P .GT. I ) THEN
+ CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
+ IF ( M-P .GT. I ) THEN
+ CALL SLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
+ END IF
*
END DO
*
@@ -470,12 +503,19 @@
DO I = Q + 1, P
*
CALL SSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 )
- CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( I .GE. M-Q ) THEN
+ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
X12(I,I) = ONE
*
- CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ IF ( P. GT. I ) THEN
+ CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL SLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
@@ -487,11 +527,18 @@
DO I = 1, M - P - Q
*
CALL SSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 )
- CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
- $ LDX22, TAUQ2(P+I) )
+ IF ( I .EQ. M-P-Q ) THEN
+ CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I),
+ $ LDX22, TAUQ2(P+I) )
+ ELSE
+ CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
+ $ LDX22, TAUQ2(P+I) )
+ END IF
X22(Q+I,P+I) = ONE
- CALL SLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
- $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
+ IF ( I .LT. M-P-Q ) THEN
+ CALL SLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
+ $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
+ END IF
*
END DO
*
@@ -521,18 +568,31 @@
*
CALL SLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
X11(I,I) = ONE
- CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
- $ TAUP2(I) )
+ IF ( I .EQ. M-P ) THEN
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
+ $ TAUP2(I) )
+ ELSE
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
+ $ TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
- CALL SLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X11(I+1,I), LDX11, WORK )
- CALL SLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X12(I,I), LDX12, WORK )
- CALL SLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
- $ X21(I+1,I), LDX21, WORK )
- CALL SLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
- $ TAUP2(I), X22(I,I), LDX22, WORK )
+ IF ( Q .GT. I ) THEN
+ CALL SLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
+ $ X11(I+1,I), LDX11, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL SLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
+ $ TAUP1(I), X12(I,I), LDX12, WORK )
+ END IF
+ IF ( Q .GT. I ) THEN
+ CALL SLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
+ $ X21(I+1,I), LDX21, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL SLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X22(I,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q ) THEN
CALL SSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 )
@@ -548,10 +608,22 @@
$ SNRM2( M-Q-I+1, X12(I,I), 1 ) )
*
IF( I .LT. Q ) THEN
- CALL SLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) )
+ IF ( Q-I .EQ. 1) THEN
+ CALL SLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1,
+ $ TAUQ1(I) )
+ ELSE
+ CALL SLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1,
+ $ TAUQ1(I) )
+ END IF
X11(I+1,I) = ONE
END IF
- CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
+ IF ( M-Q .GT. I ) THEN
+ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
+ ELSE
+ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1,
+ $ TAUQ2(I) )
+ END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@@ -562,8 +634,10 @@
END IF
CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
$ X12(I,I+1), LDX12, WORK )
- CALL SLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I),
- $ X22(I,I+1), LDX22, WORK )
+ IF ( M-P-I .GT. 0 ) THEN
+ CALL SLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I),
+ $ X22(I,I+1), LDX22, WORK )
+ END IF
*
END DO
*
@@ -575,8 +649,10 @@
CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
X12(I,I) = ONE
*
- CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
- $ X12(I,I+1), LDX12, WORK )
+ IF ( P .GT. I ) THEN
+ CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
+ $ X12(I,I+1), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL SLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I),
$ X22(I,Q+1), LDX22, WORK )
@@ -588,12 +664,18 @@
DO I = 1, M - P - Q
*
CALL SSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 )
- CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
- $ TAUQ2(P+I) )
- X22(P+I,Q+I) = ONE
+ IF ( M-P-Q .EQ. I ) THEN
+ CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1,
+ $ TAUQ2(P+I) )
+ X22(P+I,Q+I) = ONE
+ ELSE
+ CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
+ $ TAUQ2(P+I) )
+ X22(P+I,Q+I) = ONE
+ CALL SLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
+ $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK )
+ END IF
*
- CALL SLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
- $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK )
*
END DO
*
diff --git a/lapack-netlib/SRC/sorbdb1.f b/lapack-netlib/SRC/sorbdb1.f
new file mode 100644
index 000000000..b1f5f4628
--- /dev/null
+++ b/lapack-netlib/SRC/sorbdb1.f
@@ -0,0 +1,324 @@
+*> \brief \b SORBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines SORBDB2, SORBDB3, and SORBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( X21(I,I), X11(I,I) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S )
+ CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = X21(I,I+1)
+ X21(I,I+1) = ONE
+ CALL SLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL SORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of SORBDB1
+*
+ END
+
diff --git a/lapack-netlib/SRC/sorbdb2.f b/lapack-netlib/SRC/sorbdb2.f
new file mode 100644
index 000000000..582540e34
--- /dev/null
+++ b/lapack-netlib/SRC/sorbdb2.f
@@ -0,0 +1,332 @@
+*> \brief \b SORBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines SORBDB1, SORBDB3, and SORBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL NEGONE, ONE
+ PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
+ END IF
+ CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = X11(I,I)
+ X11(I,I) = ONE
+ CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL SORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL SSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL SLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL SLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of SORBDB2
+*
+ END
+
diff --git a/lapack-netlib/SRC/sorbdb3.f b/lapack-netlib/SRC/sorbdb3.f
new file mode 100644
index 000000000..ea52f4db3
--- /dev/null
+++ b/lapack-netlib/SRC/sorbdb3.f
@@ -0,0 +1,333 @@
+*> \brief \b SORBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB3 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines SORBDB1, SORBDB2, and SORBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
+ END IF
+*
+ CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = X21(I,I)
+ X21(I,I) = ONE
+ CALL SLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ C = SQRT( SNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL SORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL SLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of SORBDB3
+*
+ END
+
diff --git a/lapack-netlib/SRC/sorbdb4.f b/lapack-netlib/SRC/sorbdb4.f
new file mode 100644
index 000000000..9ed16a714
--- /dev/null
+++ b/lapack-netlib/SRC/sorbdb4.f
@@ -0,0 +1,379 @@
+*> \brief \b SORBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB4 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines SORBDB1, SORBDB2, and SORBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is REAL array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL SORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL SSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL SLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL SLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL SLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11,
+ $ WORK(ILARF) )
+ CALL SLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
+ $ LDX21, WORK(ILARF) )
+ ELSE
+ CALL SORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL SSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL SLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL SLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = X21(I,I)
+ X21(I,I) = ONE
+ CALL SLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL SLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of SORBDB4
+*
+ END
+
diff --git a/lapack-netlib/SRC/sorbdb5.f b/lapack-netlib/SRC/sorbdb5.f
new file mode 100644
index 000000000..a0b6672c0
--- /dev/null
+++ b/lapack-netlib/SRC/sorbdb5.f
@@ -0,0 +1,274 @@
+*> \brief \b SORBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB5 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is REAL array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is REAL array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is REAL array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is REAL array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORBDB6, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( SNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of SORBDB5
+*
+ END
+
diff --git a/lapack-netlib/SRC/sorbdb6.f b/lapack-netlib/SRC/sorbdb6.f
new file mode 100644
index 000000000..900316ee8
--- /dev/null
+++ b/lapack-netlib/SRC/sorbdb6.f
@@ -0,0 +1,312 @@
+*> \brief \b SORBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB6 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is REAL array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is REAL array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is REAL array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is REAL array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0,
+ $ REALZERO = 0.0E0 )
+ REAL NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of SORBDB6
+*
+ END
+
diff --git a/lapack-netlib/SRC/sorcsd.f b/lapack-netlib/SRC/sorcsd.f
index f9a47d6ac..ff4e80579 100644
--- a/lapack-netlib/SRC/sorcsd.f
+++ b/lapack-netlib/SRC/sorcsd.f
@@ -289,7 +289,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@@ -300,10 +300,10 @@
$ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T,
$ LDV2T, WORK, LWORK, IWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS
@@ -371,9 +371,22 @@
INFO = -8
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -9
- ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR.
- $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN
- INFO = -11
+ ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -11
+ ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN
+ INFO = -11
+ ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN
+ INFO = -13
+ ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -13
+ ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -15
+ ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN
+ INFO = -15
+ ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -17
+ ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -17
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -20
ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN
diff --git a/lapack-netlib/SRC/sorcsd2by1.f b/lapack-netlib/SRC/sorcsd2by1.f
new file mode 100644
index 000000000..9f02a7c16
--- /dev/null
+++ b/lapack-netlib/SRC/sorcsd2by1.f
@@ -0,0 +1,711 @@
+*> \brief \b SORCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORCSD2BY1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* ..
+* .. Array Arguments ..
+* REAL THETA(*)
+* REAL U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is REAL array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is REAL array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is REAL array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: SBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*>
+*> \par Reference:
+* ===============
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+* ..
+* .. Array Arguments ..
+ REAL THETA(*)
+ REAL U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL SBBCSD, SCOPY, SLACPY, SLAPMR, SLAPMT, SORBDB1,
+ $ SORBDB2, SORBDB3, SORBDB4, SORGLQ, SORGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-------------------------------------------------------|
+* | LWORKOPT (1) |
+* |-------------------------------------------------------|
+* | PHI (MAX(1,R-1)) |
+* |-------------------------------------------------------|
+* | TAUP1 (MAX(1,P)) | B11D (R) |
+* | TAUP2 (MAX(1,M-P)) | B11E (R-1) |
+* | TAUQ1 (MAX(1,Q)) | B12D (R) |
+* |-----------------------------------------| B12E (R-1) |
+* | SORBDB WORK | SORGQR WORK | SORGLQ WORK | B21D (R) |
+* | | | | B21E (R-1) |
+* | | | | B22D (R) |
+* | | | | B22E (R-1) |
+* | | | | SBBCSD WORK |
+* |-------------------------------------------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + MAX( 1, R )
+ IB12D = IB11E + MAX( 1, R - 1 )
+ IB12E = IB12D + MAX( 1, R )
+ IB21D = IB12E + MAX( 1, R - 1 )
+ IB21E = IB21D + MAX( 1, R )
+ IB22D = IB21E + MAX( 1, R - 1 )
+ IB22E = IB22D + MAX( 1, R )
+ IBBCSD = IB22E + MAX( 1, R - 1 )
+ ITAUP1 = IPHI + MAX( 1, R-1 )
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE
+ CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL SORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ END IF
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1,
+ $ IBBCSD+LBBCSD-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1,
+ $ IBBCSD+LBBCSD-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL SLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL SORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL SLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL SLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL SORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL SLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL SLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL SLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL SLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL SLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL SLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL SORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL SLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL SLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1,
+ $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL SLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL SLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL SCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL SLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL SORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL SCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL SLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL SLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL SLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL SLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL SORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL SLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL SLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SORCSD2BY1
+*
+ END
+
diff --git a/lapack-netlib/SRC/sstemr.f b/lapack-netlib/SRC/sstemr.f
index ba859db8b..2e995802e 100644
--- a/lapack-netlib/SRC/sstemr.f
+++ b/lapack-netlib/SRC/sstemr.f
@@ -294,7 +294,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@@ -312,10 +312,10 @@
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
@@ -389,6 +389,7 @@
WU = ZERO
IIL = 0
IIU = 0
+ NSPLIT = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
diff --git a/lapack-netlib/SRC/ssycon_rook.f b/lapack-netlib/SRC/ssycon_rook.f
new file mode 100644
index 000000000..54087d1ec
--- /dev/null
+++ b/lapack-netlib/SRC/ssycon_rook.f
@@ -0,0 +1,258 @@
+*> \brief \b SSYCON_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYCON_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* REAL A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYCON_ROOK estimates the reciprocal of the condition number (in the
+*> 1-norm) of a real symmetric matrix A using the factorization
+*> A = U*D*U**T or A = L*D*L**T computed by SSYTRF_ROOK.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is REAL
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is REAL
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup realSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SSYTRS_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYCON_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL SSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of SSYCON_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/ssysv_rook.f b/lapack-netlib/SRC/ssysv_rook.f
new file mode 100644
index 000000000..6c159338a
--- /dev/null
+++ b/lapack-netlib/SRC/ssysv_rook.f
@@ -0,0 +1,293 @@
+*> \brief SSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYSV_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+* LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYSV_ROOK computes the solution to a real system of linear
+*> equations
+*> A * X = B,
+*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*> matrices.
+*>
+*> The diagonal pivoting method is used to factor A as
+*> A = U * D * U**T, if UPLO = 'U', or
+*> A = L * D * L**T, if UPLO = 'L',
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> SSYTRF_ROOK is called to compute the factorization of a real
+*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method.
+*>
+*> The factored form of A is then used to solve the system
+*> of equations A * X = B by calling SSYTRS_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order of the
+*> matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, if INFO = 0, the block diagonal matrix D and the
+*> multipliers used to obtain the factor U or L from the
+*> factorization A = U*D*U**T or A = L*D*L**T as computed by
+*> SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by SSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \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 length of WORK. LWORK >= 1, and for best performance
+*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+*> SSYTRF_ROOK.
+*>
+*> TRS will be done with Level 2 BLAS
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, so the solution could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup realSYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, SSYTRF_ROOK, SSYTRS_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYSV_ROOK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**T or A = L*D*L**T.
+*
+ CALL SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+* Solve with TRS_ROOK ( Use Level 2 BLAS)
+*
+ CALL SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYSV_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/ssytf2.f b/lapack-netlib/SRC/ssytf2.f
index 68e4dee6b..1ca56621c 100644
--- a/lapack-netlib/SRC/ssytf2.f
+++ b/lapack-netlib/SRC/ssytf2.f
@@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup realSYcomputational
*
@@ -186,10 +195,10 @@
* =====================================================================
SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -269,7 +278,8 @@
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ISAMAX( K-1, A( 1, K ), 1 )
@@ -280,7 +290,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -437,7 +448,8 @@
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 )
@@ -448,7 +460,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
diff --git a/lapack-netlib/SRC/ssytf2_rook.f b/lapack-netlib/SRC/ssytf2_rook.f
new file mode 100644
index 000000000..270530d79
--- /dev/null
+++ b/lapack-netlib/SRC/ssytf2_rook.f
@@ -0,0 +1,813 @@
+*> \brief \b SSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTF2_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYTF2_ROOK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, U**T is the transpose of U, and D is symmetric and
+*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup realSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ ROWMAX, STEMP, T, WK, WKM1, WKP1, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSWAP, SSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTF2_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ISAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ISAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ISAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ STEMP = ABS( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL SSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL SSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL SSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ STEMP = ABS( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL SSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL SSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of SSYTF2_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/ssytrf_rook.f b/lapack-netlib/SRC/ssytrf_rook.f
new file mode 100644
index 000000000..bf60764cb
--- /dev/null
+++ b/lapack-netlib/SRC/ssytrf_rook.f
@@ -0,0 +1,393 @@
+*> \brief \b SSYTRF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTRF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYTRF_ROOK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*> The form of the factorization is
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup realSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASYF_ROOK, SSYTF2_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'SSYTRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRF_ROOK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'SSYTRF_ROOK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by SLASYF_ROOK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL SLASYF_ROOK( UPLO, K, NB, KB, A, LDA,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL SSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by SLASYF_ROOK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL SLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL SSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
+ $ IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SSYTRF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/ssytri_rook.f b/lapack-netlib/SRC/ssytri_rook.f
new file mode 100644
index 000000000..0d0dfd98a
--- /dev/null
+++ b/lapack-netlib/SRC/ssytri_rook.f
@@ -0,0 +1,450 @@
+*> \brief \b SSYTRI_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTRI_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYTRI_ROOK computes the inverse of a real symmetric
+*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
+*> computed by SSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the block diagonal matrix D and the multipliers
+*> used to obtain the factor U or L as computed by SSYTRF_ROOK.
+*>
+*> On exit, if INFO = 0, the (symmetric) inverse of the original
+*> matrix. If UPLO = 'U', the upper triangular part of the
+*> inverse is formed and the part of A below the diagonal is not
+*> referenced; if UPLO = 'L' the lower triangular part of the
+*> inverse is formed and the part of A above the diagonal is
+*> not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (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, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup realSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KP, KSTEP
+ REAL AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SSWAP, SSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRI_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K+1 ) )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ SDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL SCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ SDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K+1 with -IPIV(K) and
+* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+*
+ K = K + 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K + 1
+ GO TO 30
+ 40 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 50 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K-1 ) )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ SDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL SCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ SDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K-1 with -IPIV(K) and
+* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+*
+ K = K - 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K - 1
+ GO TO 50
+ 60 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSYTRI_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/ssytrs_rook.f b/lapack-netlib/SRC/ssytrs_rook.f
new file mode 100644
index 000000000..240b454b6
--- /dev/null
+++ b/lapack-netlib/SRC/ssytrs_rook.f
@@ -0,0 +1,484 @@
+*> \brief \b SSYTRS_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTRS_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYTRS_ROOK solves a system of linear equations A*X = B with
+*> a real symmetric matrix A using the factorization A = U*D*U**T or
+*> A = L*D*L**T computed by SSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup realSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> April 2012, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRS_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL SGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.GT.2 ) THEN
+ CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U**T *X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U**T(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.GT.1 )
+ $ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL SGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / AKM1K
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L**T *X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L**T(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSYTRS_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/stpmqrt.f b/lapack-netlib/SRC/stpmqrt.f
index 848507fc3..2763b9aff 100644
--- a/lapack-netlib/SRC/stpmqrt.f
+++ b/lapack-netlib/SRC/stpmqrt.f
@@ -175,7 +175,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@@ -216,10 +216,10 @@
SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
$ A, LDA, B, LDB, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -235,7 +235,7 @@
* ..
* .. Local Scalars ..
LOGICAL LEFT, RIGHT, TRAN, NOTRAN
- INTEGER I, IB, MB, LB, KF, Q
+ INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -257,10 +257,12 @@
TRAN = LSAME( TRANS, 'T' )
NOTRAN = LSAME( TRANS, 'N' )
*
- IF( LEFT ) THEN
- Q = M
+ IF ( LEFT ) THEN
+ LDVQ = MAX( 1, M )
+ LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
- Q = N
+ LDVQ = MAX( 1, N )
+ LDAQ = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
INFO = -1
@@ -274,13 +276,13 @@
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
INFO = -6
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
- ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
+ ELSE IF( LDV.LT.LDVQ ) THEN
INFO = -9
ELSE IF( LDT.LT.NB ) THEN
INFO = -11
- ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ ELSE IF( LDA.LT.LDAQ ) THEN
INFO = -13
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -15
diff --git a/lapack-netlib/SRC/stpqrt.f b/lapack-netlib/SRC/stpqrt.f
index d9efb26f8..139c1f737 100644
--- a/lapack-netlib/SRC/stpqrt.f
+++ b/lapack-netlib/SRC/stpqrt.f
@@ -132,7 +132,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@@ -189,10 +189,10 @@
SUBROUTINE STPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK,
$ INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDT, N, M, L, NB
@@ -219,9 +219,9 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
INFO = -3
- ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
diff --git a/lapack-netlib/SRC/zbbcsd.f b/lapack-netlib/SRC/zbbcsd.f
index dceb6b8d4..63cbde09f 100644
--- a/lapack-netlib/SRC/zbbcsd.f
+++ b/lapack-netlib/SRC/zbbcsd.f
@@ -322,7 +322,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -332,10 +332,10 @@
$ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E,
$ B22D, B22E, RWORK, LRWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
@@ -476,7 +476,10 @@
* Initial deflation
*
IMAX = Q
- DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) )
+ DO WHILE( IMAX .GT. 1 )
+ IF( PHI(IMAX-1) .NE. ZERO ) THEN
+ EXIT
+ END IF
IMAX = IMAX - 1
END DO
IMIN = IMAX - 1
diff --git a/lapack-netlib/SRC/zgebal.f b/lapack-netlib/SRC/zgebal.f
index 9c90f0b4b..ac616df89 100644
--- a/lapack-netlib/SRC/zgebal.f
+++ b/lapack-netlib/SRC/zgebal.f
@@ -121,7 +121,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16GEcomputational
*
@@ -160,10 +160,10 @@
* =====================================================================
SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
@@ -194,8 +194,8 @@
* .. External Functions ..
LOGICAL DISNAN, LSAME
INTEGER IZAMAX
- DOUBLE PRECISION DLAMCH
- EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH
+ DOUBLE PRECISION DLAMCH, DZNRM2
+ EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZSWAP
@@ -324,15 +324,9 @@
NOCONV = .FALSE.
*
DO 200 I = K, L
- C = ZERO
- R = ZERO
-*
- DO 150 J = K, L
- IF( J.EQ.I )
- $ GO TO 150
- C = C + CABS1( A( J, I ) )
- R = R + CABS1( A( I, J ) )
- 150 CONTINUE
+*
+ C = DZNRM2( L-K+1, A( K, I ), 1 )
+ R = DZNRM2( L-K+1, A( I, K ), LDA )
ICA = IZAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = IZAMAX( N-K+1, A( I, K ), LDA )
diff --git a/lapack-netlib/SRC/zgemqrt.f b/lapack-netlib/SRC/zgemqrt.f
index 71db24f27..19d684f73 100644
--- a/lapack-netlib/SRC/zgemqrt.f
+++ b/lapack-netlib/SRC/zgemqrt.f
@@ -160,7 +160,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16GEcomputational
*
@@ -168,10 +168,10 @@
SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -225,7 +225,7 @@
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN
INFO = -5
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN
INFO = -6
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
INFO = -8
diff --git a/lapack-netlib/SRC/zgeqrt.f b/lapack-netlib/SRC/zgeqrt.f
index 0decf1143..0603c4fe9 100644
--- a/lapack-netlib/SRC/zgeqrt.f
+++ b/lapack-netlib/SRC/zgeqrt.f
@@ -108,7 +108,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16GEcomputational
*
@@ -141,10 +141,10 @@
* =====================================================================
SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDT, M, N, NB
@@ -173,7 +173,7 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN
+ ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
diff --git a/lapack-netlib/SRC/zgetc2.f b/lapack-netlib/SRC/zgetc2.f
index 277ac7ce2..3179612f5 100644
--- a/lapack-netlib/SRC/zgetc2.f
+++ b/lapack-netlib/SRC/zgetc2.f
@@ -98,7 +98,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex16GEauxiliary
*
@@ -111,10 +111,10 @@
* =====================================================================
SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
@@ -203,6 +203,12 @@
INFO = N
A( N, N ) = DCMPLX( SMIN, ZERO )
END IF
+*
+* Set last pivots to N
+*
+ IPIV( N ) = N
+ JPIV( N ) = N
+*
RETURN
*
* End of ZGETC2
diff --git a/lapack-netlib/SRC/zhecon_rook.f b/lapack-netlib/SRC/zhecon_rook.f
new file mode 100644
index 000000000..9ae433650
--- /dev/null
+++ b/lapack-netlib/SRC/zhecon_rook.f
@@ -0,0 +1,253 @@
+*> \brief \b ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHECON_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHECON_ROOK estimates the reciprocal of the condition number of a complex
+*> Hermitian matrix A using the factorization A = U*D*U**H or
+*> A = L*D*L**H computed by CHETRF_ROOK.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**H;
+*> = 'L': Lower triangular, form is A = L*D*L**H.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is DOUBLE PRECISION
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is DOUBLE PRECISION
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (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
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZHETRS_ROOK, ZLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHECON_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
+*
+ CALL ZHETRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of ZHECON_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zhesv_rook.f b/lapack-netlib/SRC/zhesv_rook.f
new file mode 100644
index 000000000..3922b43f9
--- /dev/null
+++ b/lapack-netlib/SRC/zhesv_rook.f
@@ -0,0 +1,295 @@
+*> \brief \b ZHESV_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using the bounded Bunch-Kaufman ("rook") diagonal pivoting method
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHESV_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+* LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHESV_ROOK computes the solution to a complex system of linear equations
+*> A * X = B,
+*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
+*> matrices.
+*>
+*> The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used
+*> to factor A as
+*> A = U * D * U**T, if UPLO = 'U', or
+*> A = L * D * L**T, if UPLO = 'L',
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is Hermitian and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> ZHETRF_ROOK is called to compute the factorization of a complex
+*> Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method.
+*>
+*> The factored form of A is then used to solve the system
+*> of equations A * X = B by calling ZHETRS_ROOK (uses BLAS 2).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order of the
+*> matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, if INFO = 0, the block diagonal matrix D and the
+*> multipliers used to obtain the factor U or L from the
+*> factorization A = U*D*U**H or A = L*D*L**H as computed by
+*> ZHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \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 length of WORK. LWORK >= 1, and for best performance
+*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+*> ZHETRF_ROOK.
+*> for LWORK < N, TRS will be done with Level BLAS 2
+*> for LWORK >= N, TRS will be done with Level BLAS 3
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, so the solution could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16HEsolve
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+*
+* =====================================================================
+ SUBROUTINE ZHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZHETRF_ROOK, ZHETRS_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'ZHETRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHESV_ROOK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**H or A = L*D*L**H.
+*
+ CALL ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+* Solve with TRS ( Use Level BLAS 2)
+*
+ CALL ZHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of ZHESV_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zhetf2.f b/lapack-netlib/SRC/zhetf2.f
index 85968c208..612d9c5df 100644
--- a/lapack-netlib/SRC/zhetf2.f
+++ b/lapack-netlib/SRC/zhetf2.f
@@ -1,25 +1,25 @@
-*> \brief \b ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm).
+*> \brief \b ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm, calling Level 2 BLAS).
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download ZHETF2 + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download ZHETF2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
@@ -28,7 +28,7 @@
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@@ -113,12 +122,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex16HEcomputational
*
@@ -182,10 +191,10 @@
* =====================================================================
SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -273,7 +282,8 @@
ABSAKK = ABS( DBLE( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, A( 1, K ), 1 )
@@ -284,13 +294,19 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@@ -299,7 +315,8 @@
ELSE
*
* JMAX is the column-index of the largest off-diagonal
-* element in row IMAX, and ROWMAX is its absolute value
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine only ROWMAX.
*
JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
@@ -313,6 +330,7 @@
* no interchange, use 1-by-1 pivot block
*
KP = K
+*
ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@@ -328,7 +346,10 @@
KP = IMAX
KSTEP = 2
END IF
+*
END IF
+*
+* ============================================================
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
@@ -456,7 +477,8 @@
ABSAKK = ABS( DBLE( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
@@ -467,13 +489,19 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
-* Column K is zero or contains a NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@@ -482,7 +510,8 @@
ELSE
*
* JMAX is the column-index of the largest off-diagonal
-* element in row IMAX, and ROWMAX is its absolute value
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine only ROWMAX.
*
JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
@@ -496,6 +525,7 @@
* no interchange, use 1-by-1 pivot block
*
KP = K
+*
ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@@ -511,7 +541,10 @@
KP = IMAX
KSTEP = 2
END IF
+*
END IF
+*
+* ============================================================
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
diff --git a/lapack-netlib/SRC/zhetf2_rook.f b/lapack-netlib/SRC/zhetf2_rook.f
new file mode 100644
index 000000000..7d524cdb0
--- /dev/null
+++ b/lapack-netlib/SRC/zhetf2_rook.f
@@ -0,0 +1,910 @@
+*> \brief \b ZHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETF2_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHETF2_ROOK computes the factorization of a complex Hermitian matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
+*>
+*> A = U*D*U**H or A = L*D*L**H
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, U**H is the conjugate transpose of U, and D is
+*> Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**H, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**H, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * )
+* ..
+*
+* ======================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE, UPPER
+ INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP,
+ $ P
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, DTEMP,
+ $ ROWMAX, TT, SFMIN
+ COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL LSAME, IZAMAX, DLAMCH, DLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZDSCAL, ZHER, ZSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETF2_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**H using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( A( K, K ) )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the leading submatrix A(1:k,1:k)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.GT.1 )
+ $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 14 J = P + 1, K - 1
+ T = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( P, J ) )
+ A( P, J ) = T
+ 14 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = DCONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( K, K ) )
+ A( K, K ) = DBLE( A( P, P ) )
+ A( P, P ) = R1
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the leading submatrix A(1:k,1:k)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 15 J = KP + 1, KK - 1
+ T = DCONJG( A( J, KK ) )
+ A( J, KK ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 15 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = DCONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( KK, KK ) )
+ A( KK, KK ) = DBLE( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+* (5) Swap row elements
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K-1, K-1 ) = DBLE( A( K-1, K-1 ) )
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / DBLE( A( K, K ) )
+ CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL ZDSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = DBLE( A( K, K ) )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+* D = |A12|
+ D = DLAPY2( DBLE( A( K-1, K ) ),
+ $ DIMAG( A( K-1, K ) ) )
+ D11 = A( K, K ) / D
+ D22 = A( K-1, K-1 ) / D
+ D12 = A( K-1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )*
+ $ A( J, K ) )
+ WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) )
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2)
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*DCONJG( WK ) -
+ $ ( A( I, K-1 ) / D )*DCONJG( WKM1 )
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K-1 ) = WKM1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO )
+*
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**H using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( A( K, K ) )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 42
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the trailing submatrix A(k:n,k:n)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.LT.N )
+ $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 44 J = K + 1, P - 1
+ T = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( P, J ) )
+ A( P, J ) = T
+ 44 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = DCONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( K, K ) )
+ A( K, K ) = DBLE( A( P, P ) )
+ A( P, P ) = R1
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the trailing submatrix A(k:n,k:n)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 45 J = KK + 1, KP - 1
+ T = DCONJG( A( J, KK ) )
+ A( J, KK ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 45 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = DCONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( KK, KK ) )
+ A( KK, KK ) = DBLE( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+* (5) Swap row elements
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) )
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of A now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+* Handle division by a small number
+*
+ IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / DBLE( A( K, K ) )
+ CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL ZDSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = DBLE( A( K, K ) )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+* D = |A21|
+ D = DLAPY2( DBLE( A( K+1, K ) ),
+ $ DIMAG( A( K+1, K ) ) )
+ D11 = DBLE( A( K+1, K+1 ) ) / D
+ D22 = DBLE( A( K, K ) ) / D
+ D21 = A( K+1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) )
+ WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )*
+ $ A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*DCONJG( WK ) -
+ $ ( A( I, K+1 ) / D )*DCONJG( WKP1 )
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K+1 ) = WKP1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO )
+*
+ 60 CONTINUE
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of ZHETF2_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zhetrf_rook.f b/lapack-netlib/SRC/zhetrf_rook.f
new file mode 100644
index 000000000..64e59aab5
--- /dev/null
+++ b/lapack-netlib/SRC/zhetrf_rook.f
@@ -0,0 +1,397 @@
+*> \brief \b ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETRF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHETRF_ROOK computes the factorization of a complex Hermitian matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*> The form of the factorization is
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is Hermitian and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLAHEF_ROOK, ZHETF2_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'ZHETRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETRF_ROOK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'ZHETRF_ROOK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by ZLAHEF_ROOK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL ZLAHEF_ROOK( UPLO, K, NB, KB, A, LDA,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL ZHETF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by ZLAHEF_ROOK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL ZLAHEF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL ZHETF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
+ $ IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of ZHETRF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zhetri_rook.f b/lapack-netlib/SRC/zhetri_rook.f
new file mode 100644
index 000000000..68b88acbd
--- /dev/null
+++ b/lapack-netlib/SRC/zhetri_rook.f
@@ -0,0 +1,516 @@
+*> \brief \b ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETRI_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix
+*> A using the factorization A = U*D*U**H or A = L*D*L**H computed by
+*> ZHETRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**H;
+*> = 'L': Lower triangular, form is A = L*D*L**H.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the block diagonal matrix D and the multipliers
+*> used to obtain the factor U or L as computed by ZHETRF_ROOK.
+*>
+*> On exit, if INFO = 0, the (Hermitian) inverse of the original
+*> matrix. If UPLO = 'U', the upper triangular part of the
+*> inverse is formed and the part of A below the diagonal is not
+*> referenced; if UPLO = 'L' the lower triangular part of the
+*> inverse is formed and the part of A above the diagonal is
+*> not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (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, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ COMPLEX*16 CONE, CZERO
+ PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ),
+ $ CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP, KSTEP
+ DOUBLE PRECISION AK, AKP1, D, T
+ COMPLEX*16 AKKP1, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ COMPLEX*16 ZDOTC
+ EXTERNAL LSAME, ZDOTC
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZCOPY, ZHEMV, ZSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DCONJG, MAX, DBLE
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETRI_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U**H.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 70
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / DBLE( A( K, K ) )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1, A( 1,
+ $ K ), 1 ) )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K+1 ) )
+ AK = DBLE( A( K, K ) ) / T
+ AKP1 = DBLE( A( K+1, K+1 ) ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1, A( 1,
+ $ K ), 1 ) )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ ZDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ DBLE( ZDOTC( K-1, WORK, 1, A( 1, K+1 ),
+ $ 1 ) )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the leading
+* submatrix A(1:k,1:k)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+*
+ DO 40 J = KP + 1, K - 1
+ TEMP = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 40 CONTINUE
+*
+ A( KP, K ) = DCONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K+1 with -IPIV(K) and
+* -IPIV(K+1) in the leading submatrix A(k+1:n,k+1:n)
+*
+* (1) Interchange rows and columns K and -IPIV(K)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+*
+ DO 50 J = KP + 1, K - 1
+ TEMP = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 50 CONTINUE
+*
+ A( KP, K ) = DCONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+*
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+*
+* (2) Interchange rows and columns K+1 and -IPIV(K+1)
+*
+ K = K + 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+*
+ DO 60 J = KP + 1, K - 1
+ TEMP = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 60 CONTINUE
+*
+ A( KP, K ) = DCONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K + 1
+ GO TO 30
+ 70 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L**H.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 80 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 120
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / DBLE( A( K, K ) )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+ $ 1, CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1,
+ $ A( K+1, K ), 1 ) )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K-1 ) )
+ AK = DBLE( A( K-1, K-1 ) ) / T
+ AKP1 = DBLE( A( K, K ) ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+ $ 1, CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1,
+ $ A( K+1, K ), 1 ) )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ ZDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+ $ 1, CZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ DBLE( ZDOTC( N-K, WORK, 1, A( K+1, K-1 ),
+ $ 1 ) )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the trailing
+* submatrix A(k:n,k:n)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+*
+ DO 90 J = K + 1, KP - 1
+ TEMP = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 90 CONTINUE
+*
+ A( KP, K ) = DCONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K-1 with -IPIV(K) and
+* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
+*
+* (1) Interchange rows and columns K and -IPIV(K)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+*
+ DO 100 J = K + 1, KP - 1
+ TEMP = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 100 CONTINUE
+*
+ A( KP, K ) = DCONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+*
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+*
+* (2) Interchange rows and columns K-1 and -IPIV(K-1)
+*
+ K = K - 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+*
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+*
+ DO 110 J = K + 1, KP - 1
+ TEMP = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = TEMP
+ 110 CONTINUE
+*
+ A( KP, K ) = DCONJG( A( KP, K ) )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K - 1
+ GO TO 80
+ 120 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZHETRI_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zhetrs_rook.f b/lapack-netlib/SRC/zhetrs_rook.f
new file mode 100644
index 000000000..f99697ca5
--- /dev/null
+++ b/lapack-netlib/SRC/zhetrs_rook.f
@@ -0,0 +1,503 @@
+*> \brief \b ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETRS_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHETRS_ROOK solves a system of linear equations A*X = B with a complex
+*> Hermitian matrix A using the factorization A = U*D*U**H or
+*> A = L*D*L**H computed by ZHETRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**H;
+*> = 'L': Lower triangular, form is A = L*D*L**H.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by ZHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZHETRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ DOUBLE PRECISION S
+ COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEMV, ZGERU, ZLACGV, ZDSCAL, ZSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DCONJG, MAX, DBLE
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETRS_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U**H.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL ZGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ S = DBLE( ONE ) / DBLE( A( K, K ) )
+ CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1)
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ CALL ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+ CALL ZGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / DCONJG( AKM1K )
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / DCONJG( AKM1K )
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U**H *X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U**H(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+*
+ CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+ $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L**H.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL ZGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ S = DBLE( ONE ) / DBLE( A( K, K ) )
+ CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / DCONJG( AKM1K )
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / DCONJG( AKM1K )
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L**H *X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L**H(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+ $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+ $ B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+ $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+ $ B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+*
+ CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+ $ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE,
+ $ B( K-1, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZHETRS_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zhsein.f b/lapack-netlib/SRC/zhsein.f
index 6c7173f1c..57c99dbea 100644
--- a/lapack-netlib/SRC/zhsein.f
+++ b/lapack-netlib/SRC/zhsein.f
@@ -104,6 +104,7 @@
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> The upper Hessenberg matrix H.
+*> If a NaN is detected in H, the routine will return with INFO=-6.
*> \endverbatim
*>
*> \param[in] LDH
@@ -225,7 +226,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -244,10 +245,10 @@
$ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL,
$ IFAILR, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
@@ -276,9 +277,9 @@
COMPLEX*16 CDUM, WK
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH, ZLANHS
- EXTERNAL LSAME, DLAMCH, ZLANHS
+ EXTERNAL LSAME, DLAMCH, ZLANHS, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLAEIN
@@ -399,7 +400,10 @@
* has not ben computed before.
*
HNORM = ZLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, RWORK )
- IF( HNORM.GT.RZERO ) THEN
+ IF( DISNAN( HNORM ) ) THEN
+ INFO = -6
+ RETURN
+ ELSE IF( HNORM.GT.RZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
diff --git a/lapack-netlib/SRC/zhseqr.f b/lapack-netlib/SRC/zhseqr.f
index e9fe20401..994843688 100644
--- a/lapack-netlib/SRC/zhseqr.f
+++ b/lapack-netlib/SRC/zhseqr.f
@@ -43,7 +43,7 @@
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
-*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
*> \endverbatim
*
* Arguments:
@@ -216,7 +216,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -299,10 +299,10 @@
SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
$ WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
diff --git a/lapack-netlib/SRC/zlahef.f b/lapack-netlib/SRC/zlahef.f
index 71daaf8e8..36b9b73ce 100644
--- a/lapack-netlib/SRC/zlahef.f
+++ b/lapack-netlib/SRC/zlahef.f
@@ -1,4 +1,4 @@
-*> \brief \b ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix, using the diagonal pivoting method.
+*> \brief \b ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
*
* =========== DOCUMENTATION ===========
*
@@ -110,16 +110,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If UPLO = 'U', only the last KB elements of IPIV are set;
-*> if UPLO = 'L', only the first KB elements are set.
*>
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@@ -150,17 +160,27 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex16HEcomputational
*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*> \endverbatim
+*
* =====================================================================
SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -230,6 +250,8 @@
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
+*
+ KSTEP = 1
*
* Copy column K of A to column KW of W and update it
*
@@ -240,8 +262,6 @@
$ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
W( K, KW ) = DBLE( W( K, KW ) )
END IF
-*
- KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
@@ -249,7 +269,8 @@
ABSAKK = ABS( DBLE( W( K, KW ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
@@ -260,13 +281,19 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@@ -274,6 +301,9 @@
KP = K
ELSE
*
+* BEGIN pivot search along IMAX row
+*
+*
* Copy column IMAX to column KW-1 of W and update it
*
CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
@@ -289,7 +319,8 @@
END IF
*
* JMAX is the column-index of the largest off-diagonal
-* element in row IMAX, and ROWMAX is its absolute value
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine only ROWMAX.
*
JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = CABS1( W( JMAX, KW-1 ) )
@@ -298,11 +329,14 @@
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) )
END IF
*
+* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
+*
+* Case(3)
ELSE IF( ABS( DBLE( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@@ -311,9 +345,11 @@
*
KP = IMAX
*
-* copy column KW-1 of W to column KW
+* copy column KW-1 of W to column KW of W
*
CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+* Case(4)
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
@@ -322,27 +358,48 @@
KP = IMAX
KSTEP = 2
END IF
+*
+*
+* END pivot search along IMAX row
+*
END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
KKW = NB + KK - N
*
-* Updated column KP is already stored in column KKW of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
A( KP, KP ) = DBLE( A( KK, KK ) )
CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
- CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( KP.GT.1 )
+ $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
-* Interchange rows KK and KP in last KK columns of A and W
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
*
- IF( KK.LT.N )
- $ CALL ZSWAP( N-KK, A( KK, KK+1 ), LDA, A( KP, KK+1 ),
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
$ LDA )
CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
@@ -350,40 +407,108 @@
*
IF( KSTEP.EQ.1 ) THEN
*
-* 1-by-1 pivot block D(k): column KW of W now holds
+* 1-by-1 pivot block D(k): column kw of W now holds
*
-* W(k) = U(k)*D(k)
+* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
-* Store U(k) in column k of A
+* (1) Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
- R1 = ONE / DBLE( A( K, K ) )
- CALL ZDSCAL( K-1, R1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
*
-* Conjugate W(k)
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(4))
+*
+ R1 = ONE / DBLE( A( K, K ) )
+ CALL ZDSCAL( K-1, R1, A( 1, K ), 1 )
+*
+* (2) Conjugate column W(kw)
+*
+ CALL ZLACGV( K-1, W( 1, KW ), 1 )
+ END IF
*
- CALL ZLACGV( K-1, W( 1, KW ), 1 )
ELSE
*
-* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
-* hold
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
-* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
+*
+* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored)
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
-* Store U(k) and U(k-1) in columns k and k-1 of A
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( conj(D21)*( D11 ) D21*( -1 ) )
+* ( ( -1 ) ( D22 ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = T/d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0, since in 2x2 pivot case(4)
+* |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / DCONJG( D21 )
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( DBLE( D11*D22 )-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = DCONJG( D21 )*
@@ -397,11 +522,13 @@
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
*
-* Conjugate W(k) and W(k-1)
+* (2) Conjugate columns W(kw) and W(kw-1)
*
CALL ZLACGV( K-1, W( 1, KW ), 1 )
CALL ZLACGV( K-2, W( 1, KW-1 ), 1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -448,20 +575,28 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
-* in columns k+1:n
+* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J + 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
J = J + 1
- END IF
- J = J + 1
- IF( JP.NE.JJ .AND. J.LE.N )
- $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
- IF( J.LE.N )
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
@@ -483,6 +618,8 @@
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
+*
+ KSTEP = 1
*
* Copy column K of A to column K of W and update it
*
@@ -492,8 +629,6 @@
CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
$ W( K, 1 ), LDW, CONE, W( K, K ), 1 )
W( K, K ) = DBLE( W( K, K ) )
-*
- KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
@@ -501,7 +636,8 @@
ABSAKK = ABS( DBLE( W( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
@@ -512,13 +648,19 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@@ -526,6 +668,9 @@
KP = K
ELSE
*
+* BEGIN pivot search along IMAX row
+*
+*
* Copy column IMAX to column K+1 of W and update it
*
CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
@@ -540,7 +685,8 @@
W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) )
*
* JMAX is the column-index of the largest off-diagonal
-* element in row IMAX, and ROWMAX is its absolute value
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine only ROWMAX.
*
JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = CABS1( W( JMAX, K+1 ) )
@@ -549,11 +695,14 @@
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) )
END IF
*
+* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
+*
+* Case(3)
ELSE IF( ABS( DBLE( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@@ -562,9 +711,11 @@
*
KP = IMAX
*
-* copy column K+1 of W to column K
+* copy column K+1 of W to column K of W
*
CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+* Case(4)
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
@@ -573,15 +724,29 @@
KP = IMAX
KSTEP = 2
END IF
+*
+*
+* END pivot search along IMAX row
+*
END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
-* Updated column KP is already stored in column KK of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
A( KP, KP ) = DBLE( A( KK, KK ) )
CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
@@ -590,9 +755,13 @@
IF( KP.LT.N )
$ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
-* Interchange rows KK and KP in first KK columns of A and W
+* Interchange rows KK and KP in first K-1 columns of A
+* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
*
- CALL ZSWAP( KK-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ IF( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@@ -600,21 +769,35 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
-* W(k) = L(k)*D(k)
+* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
-* Store L(k) in column k of A
+* (1) Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(4))
+*
R1 = ONE / DBLE( A( K, K ) )
CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 )
*
-* Conjugate W(k)
+* (2) Conjugate column W(k)
*
CALL ZLACGV( N-K, W( K+1, K ), 1 )
END IF
+*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@@ -623,16 +806,69 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
+*
+* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored)
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
-* Store L(k) and L(k+1) in columns k and k+1 of A
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( conj(D21)*( D11 ) D21*( -1 ) )
+* ( ( -1 ) ( D22 ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = T/d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0, since in 2x2 pivot case(4)
+* |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / DCONJG( D21 )
T = ONE / ( DBLE( D11*D22 )-ONE )
D21 = T / D21
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
DO 80 J = K + 2, N
A( J, K ) = DCONJG( D21 )*
$ ( D11*W( J, K )-W( J, K+1 ) )
@@ -646,11 +882,13 @@
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
*
-* Conjugate W(k) and W(k+1)
+* (2) Conjugate columns W(k) and W(k+1)
*
CALL ZLACGV( N-K, W( K+1, K ), 1 )
CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -698,20 +936,28 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
-* in columns 1:k-1
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J - 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
J = J - 1
- END IF
- J = J - 1
- IF( JP.NE.JJ .AND. J.GE.1 )
- $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
- IF( J.GE.1 )
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
diff --git a/lapack-netlib/SRC/zlahef_rook.f b/lapack-netlib/SRC/zlahef_rook.f
new file mode 100644
index 000000000..1a344a30f
--- /dev/null
+++ b/lapack-netlib/SRC/zlahef_rook.f
@@ -0,0 +1,1176 @@
+* \brief \b ZLAHEF_ROOK computes a partial factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAHEF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAHEF_ROOK computes a partial factorization of a complex Hermitian
+*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting
+*> method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L'
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*> Note that U**H denotes the conjugate transpose of U.
+*>
+*> ZLAHEF_ROOK is an auxiliary routine called by ZHETRF_ROOK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*> On exit, A contains details of the partial factorization.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ COMPLEX*16 CONE
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K,
+ $ KK, KKW, KP, KSTEP, KW, P
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, DTEMP, R1, ROWMAX, T,
+ $ SFMIN
+ COMPLEX*16 D11, D21, D22, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IZAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, ZSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11 (note that conjg(W) is actually stored)
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ IF( K.GT.1 )
+ $ CALL ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
+ W( K, KW ) = DBLE( A( K, K ) )
+ IF( K.LT.N ) THEN
+ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+ $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+ W( K, KW ) = DBLE( W( K, KW ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( W( K, KW ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( W( K, KW ) )
+ IF( K.GT.1 )
+ $ CALL ZCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+* Lop until pivot found
+*
+ DONE = .FALSE.
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ IF( IMAX.GT.1 )
+ $ CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ),
+ $ 1 )
+ W( IMAX, KW-1 ) = DBLE( A( IMAX, IMAX ) )
+*
+ CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+ CALL ZLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N ) THEN
+ CALL ZGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+ W( IMAX, KW-1 ) = DBLE( W( IMAX, KW-1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ DTEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( W( IMAX,KW-1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+* Interchange rows and columns P and K.
+* Updated column P is already stored in column KW of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K-1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = DBLE( A( K, K ) )
+ CALL ZCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ CALL ZLACGV( K-1-P, A( P, P+1 ), LDA )
+ IF( P.GT.1 )
+ $ CALL ZCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in the last K+1 to N columns of A
+* (columns K and K-1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ),
+ $ LDA )
+ CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ),
+ $ LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = DBLE( A( KK, KK ) )
+ CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
+ IF( KP.GT.1 )
+ $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+ CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column kw of W now holds
+*
+* W(kw) = U(k)*D(k),
+*
+* where U(k) is the k-th column of U
+*
+* (1) Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = DBLE( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL ZDSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+ DO 14 II = 1, K-1
+ A( II, K ) = A( II, K ) / T
+ 14 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(kw)
+*
+ CALL ZLACGV( K-1, W( 1, KW ), 1 )
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
+*
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored)
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
+*
+ IF( K.GT.2 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K-1, KW )
+ D11 = W( K, KW ) / DCONJG( D21 )
+ D22 = W( K-1, KW-1 ) / D21
+ T = ONE / ( DBLE( D11*D22 )-ONE )
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D21 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ DCONJG( D21 ) )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+*
+* (2) Conjugate columns W(kw) and W(kw-1)
+*
+ CALL ZLACGV( K-1, W( 1, KW ), 1 )
+ CALL ZLACGV( K-2, W( 1, KW-1 ), 1 )
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+ $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in of rows in columns k+1:n looping backwards from k+1 to n
+*
+ J = K + 1
+ 60 CONTINUE
+*
+* Undo the interchanges (if any) of rows J and JP2
+* (or J and JP2, and J+1 and JP1) at each step J
+*
+ KSTEP = 1
+ JP1 = 1
+* (Here, J is a diagonal index)
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+* (Here, J is a diagonal index)
+ J = J + 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
+ J = J + 1
+ IF( JP2.NE.JJ .AND. J.LE.N )
+ $ CALL ZSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
+ JJ = JJ + 1
+ IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.LE.N )
+ $ CALL ZSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LT.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22 (note that conjg(W) is actually stored)
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update column K of W
+*
+ W( K, K ) = DBLE( A( K, K ) )
+ IF( K.LT.N )
+ $ CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+ W( K, K ) = DBLE( W( K, K ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( W( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( W( K, K ) )
+ IF( K.LT.N )
+ $ CALL ZCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column k+1 of W and update it
+*
+ CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) )
+*
+ IF( IMAX.LT.N )
+ $ CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
+ $ W( IMAX+1, K+1 ), 1 )
+*
+ IF( K.GT.1 ) THEN
+ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ DTEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( W( IMAX,K+1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+*
+* End pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 72
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* Interchange rows and columns P and K (only for 2-by-2 pivot).
+* Updated column P is already stored in column K of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column KK-1 to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K+1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = DBLE( A( K, K ) )
+ CALL ZCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ CALL ZLACGV( P-K-1, A( P, K+1 ), LDA )
+ IF( P.LT.N )
+ $ CALL ZCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+*
+* Interchange rows K and P in first K-1 columns of A
+* (columns K and K+1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = DBLE( A( KK, KK ) )
+ CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
+ IF( KP.LT.N )
+ $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+*
+* Interchange rows KK and KP in first K-1 columns of A
+* (column K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+* (1) Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = DBLE( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / T
+ 74 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(k)
+*
+ CALL ZLACGV( N-K, W( K+1, K ), 1 )
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored.
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / DCONJG( D21 )
+ T = ONE / ( DBLE( D11*D22 )-ONE )
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ DCONJG( D21 ) )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+*
+* (2) Conjugate columns W(k) and W(k+1)
+*
+ CALL ZLACGV( N-K, W( K+1, K ), 1 )
+ CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 )
+*
+ END IF
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
+*
+ J = K - 1
+ 120 CONTINUE
+*
+* Undo the interchanges (if any) of rows J and JP2
+* (or J and JP2, and J-1 and JP1) at each step J
+*
+ KSTEP = 1
+ JP1 = 1
+* (Here, J is a diagonal index)
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+* (Here, J is a diagonal index)
+ J = J - 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
+ J = J - 1
+ IF( JP2.NE.JJ .AND. J.GE.1 )
+ $ CALL ZSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
+ JJ = JJ -1
+ IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.GE.1 )
+ $ CALL ZSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GT.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of ZLAHEF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zlarfb.f b/lapack-netlib/SRC/zlarfb.f
index 99490f582..480f543fa 100644
--- a/lapack-netlib/SRC/zlarfb.f
+++ b/lapack-netlib/SRC/zlarfb.f
@@ -159,7 +159,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date June 2013
*
*> \ingroup complex16OTHERauxiliary
*
@@ -195,10 +195,10 @@
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@@ -217,12 +217,11 @@
* ..
* .. Local Scalars ..
CHARACTER TRANST
- INTEGER I, J, LASTV, LASTC
+ INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
- INTEGER ILAZLR, ILAZLC
- EXTERNAL LSAME, ILAZLR, ILAZLC
+ EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
@@ -255,36 +254,33 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
- LASTC = ILAZLC( LASTV, N, C, LDC )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C1**H
*
DO 10 J = 1, K
- CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
- CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL ZLACGV( N, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
- CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
-* W := W + C2**H *V2
+* W := W + C2**H * V2
*
- CALL ZGEMM( 'Conjugate transpose', 'No transpose',
- $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
- $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
+ CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
+ $ K, M-K, ONE, C( K+1, 1 ), LDC,
+ $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
@@ -293,20 +289,19 @@
* C2 := C2 - V2 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTV-K, LASTC, K,
- $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
- $ ONE, C( K+1, 1 ), LDC )
+ $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
+ $ LDWORK, ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 30 J = 1, K
- DO 20 I = 1, LASTC
+ DO 20 I = 1, N
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
@@ -314,58 +309,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
- LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
- CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
- CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
- CALL ZGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, LASTV-K,
- $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
- $ ONE, WORK, LDWORK )
+ CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**H
*
- CALL ZGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
- $ ONE, C( 1, K+1 ), LDC )
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
+ $ LDV, ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
- DO 50 I = 1, LASTC
+ DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
@@ -381,38 +371,33 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
-*
- LASTC = ILAZLC( M, N, C, LDC )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C2**H
*
DO 70 J = 1, K
- CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
- CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL ZLACGV( N, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
- CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
-* W := W + C1**H*V1
+* W := W + C1**H * V1
*
- CALL ZGEMM( 'Conjugate transpose', 'No transpose',
- $ LASTC, K, M-K,
- $ ONE, C, LDC, V, LDV,
- $ ONE, WORK, LDWORK )
+ CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
+ $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
+ $ LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
@@ -421,21 +406,20 @@
* C1 := C1 - V1 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
- $ M-K, LASTC, K,
- $ -ONE, V, LDV, WORK, LDWORK,
- $ ONE, C, LDC )
+ $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
+ $ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
+ $ LDWORK )
*
* C2 := C2 - W**H
*
DO 90 J = 1, K
- DO 80 I = 1, LASTC
+ DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ DCONJG( WORK( I, J ) )
80 CONTINUE
@@ -444,36 +428,31 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTC = ILAZLR( M, N, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
- CALL ZCOPY( LASTC, C( 1, N-K+J ), 1,
- $ WORK( 1, J ), 1 )
+ CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
- CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
- CALL ZGEMM( 'No transpose', 'No transpose',
- $ LASTC, K, N-K,
- $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
@@ -481,23 +460,22 @@
*
* C1 := C1 - W * V1**H
*
- CALL ZGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
+ $ C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
+ $ LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
- DO 110 I = 1, LASTC
- C( I, N-K+J ) = C( I, N-K+J )
- $ - WORK( I, J )
+ DO 110 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
@@ -514,59 +492,56 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
-*
- LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
- LASTC = ILAZLC( LASTV, N, C, LDC )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C1**H
*
DO 130 J = 1, K
- CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
- CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL ZLACGV( N, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
*
-* W := W + C2**H*V2**H
+* W := W + C2**H * V2**H
*
CALL ZGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', LASTC, K, LASTV-K,
- $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
- $ ONE, WORK, LDWORK )
+ $ 'Conjugate transpose', N, K, M-K, ONE,
+ $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+ $ WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
- IF( LASTV.GT.K ) THEN
+ IF( M.GT.K ) THEN
*
* C2 := C2 - V2**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', LASTV-K, LASTC, K,
- $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
- $ ONE, C( K+1, 1 ), LDC )
+ $ 'Conjugate transpose', M-K, N, K, -ONE,
+ $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
- CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 150 J = 1, K
- DO 140 I = 1, LASTC
+ DO 140 I = 1, N
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
@@ -574,57 +549,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
- LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
- CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+ CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
- IF( LASTV.GT.K ) THEN
+ $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
*
* W := W + C2 * V2**H
*
- CALL ZGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
- $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ K, N-K, ONE, C( 1, K+1 ), LDC,
+ $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
- IF( LASTV.GT.K ) THEN
+ IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
- CALL ZGEMM( 'No transpose', 'No transpose',
- $ LASTC, LASTV-K, K,
- $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
- $ ONE, C( 1, K+1 ), LDC )
+ CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
- CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
- DO 170 I = 1, LASTC
+ DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
@@ -640,37 +611,34 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
-*
- LASTC = ILAZLC( M, N, C, LDC )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C2**H
*
DO 190 J = 1, K
- CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC,
- $ WORK( 1, J ), 1 )
- CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+ CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ CALL ZLACGV( N, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
+ $ LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1**H
*
CALL ZGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', LASTC, K, M-K,
- $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ $ 'Conjugate transpose', N, K, M-K, ONE, C,
+ $ LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
- CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
@@ -679,20 +647,19 @@
* C1 := C1 - V1**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
- $ 'Conjugate transpose', M-K, LASTC, K,
- $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+ $ 'Conjugate transpose', M-K, N, K, -ONE, V,
+ $ LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 210 J = 1, K
- DO 200 I = 1, LASTC
+ DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ DCONJG( WORK( I, J ) )
200 CONTINUE
@@ -701,36 +668,33 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
-*
- LASTC = ILAZLR( M, N, C, LDC )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
- CALL ZCOPY( LASTC, C( 1, N-K+J ), 1,
- $ WORK( 1, J ), 1 )
+ CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
- $ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
+ $ LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**H
*
- CALL ZGEMM( 'No transpose', 'Conjugate transpose',
- $ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE,
- $ WORK, LDWORK )
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+ $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
+ $ LDWORK )
END IF
*
* W := W * T or W * T**H
*
- CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
- $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
@@ -738,21 +702,19 @@
*
* C1 := C1 - W * V1
*
- CALL ZGEMM( 'No transpose', 'No transpose',
- $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
- $ ONE, C, LDC )
+ CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
- CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
- $ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
- $ WORK, LDWORK )
+ CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
- DO 230 I = 1, LASTC
+ DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
diff --git a/lapack-netlib/SRC/zlartg.f b/lapack-netlib/SRC/zlartg.f
index e790021c6..3e2260223 100644
--- a/lapack-netlib/SRC/zlartg.f
+++ b/lapack-netlib/SRC/zlartg.f
@@ -85,7 +85,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex16OTHERauxiliary
*
@@ -103,10 +103,10 @@
* =====================================================================
SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
DOUBLE PRECISION CS
@@ -130,7 +130,8 @@
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
- EXTERNAL DLAMCH, DLAPY2
+ LOGICAL DISNAN
+ EXTERNAL DLAMCH, DLAPY2, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
@@ -139,26 +140,17 @@
* .. Statement Functions ..
DOUBLE PRECISION ABS1, ABSSQ
* ..
-* .. Save statement ..
-* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
-* ..
-* .. Data statements ..
-* DATA FIRST / .TRUE. /
-* ..
* .. Statement Function definitions ..
ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
* ..
* .. Executable Statements ..
*
-* IF( FIRST ) THEN
- SAFMIN = DLAMCH( 'S' )
- EPS = DLAMCH( 'E' )
- SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
- $ LOG( DLAMCH( 'B' ) ) / TWO )
- SAFMX2 = ONE / SAFMN2
-* FIRST = .FALSE.
-* END IF
+ SAFMIN = DLAMCH( 'S' )
+ EPS = DLAMCH( 'E' )
+ SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+ $ LOG( DLAMCH( 'B' ) ) / TWO )
+ SAFMX2 = ONE / SAFMN2
SCALE = MAX( ABS1( F ), ABS1( G ) )
FS = F
GS = G
@@ -172,7 +164,7 @@
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
ELSE IF( SCALE.LE.SAFMN2 ) THEN
- IF( G.EQ.CZERO ) THEN
+ IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN
CS = ONE
SN = CZERO
R = F
diff --git a/lapack-netlib/SRC/zlasyf.f b/lapack-netlib/SRC/zlasyf.f
index a732eae5f..b0f48fbbc 100644
--- a/lapack-netlib/SRC/zlasyf.f
+++ b/lapack-netlib/SRC/zlasyf.f
@@ -1,25 +1,25 @@
-*> \brief \b ZLASYF computes a partial factorization of a complex symmetric matrix, using the diagonal pivoting method.
+*> \brief \b ZLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download ZLASYF + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download ZLASYF + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
@@ -28,7 +28,7 @@
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), W( LDW, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -110,16 +110,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If UPLO = 'U', only the last KB elements of IPIV are set;
-*> if UPLO = 'L', only the first KB elements are set.
*>
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@@ -145,22 +155,32 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex16SYcomputational
*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*> \endverbatim
+*
* =====================================================================
SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -246,7 +266,7 @@
ABSAKK = CABS1( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
@@ -257,7 +277,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -302,7 +322,7 @@
*
KP = IMAX
*
-* copy column KW-1 of W to column KW
+* copy column KW-1 of W to column KW of W
*
CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
@@ -314,60 +334,118 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
KKW = NB + KK - N
*
-* Updated column KP is already stored in column KKW of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL ZCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ A( KP, KP ) = A( KK, KK )
+ CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
- CALL ZCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( KP.GT.1 )
+ $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
-* Interchange rows KK and KP in last KK columns of A and W
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
*
- CALL ZSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
-* 1-by-1 pivot block D(k): column KW of W now holds
+* 1-by-1 pivot block D(k): column kw of W now holds
*
-* W(k) = U(k)*D(k)
+* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
-* Store U(k) in column k of A
+* Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored.
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = CONE / A( K, K )
CALL ZSCAL( K-1, R1, A( 1, K ), 1 )
+*
ELSE
*
-* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
-* hold
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
-* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
+*
+* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored.
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
-* Store U(k) and U(k-1) in columns k and k-1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
@@ -379,7 +457,9 @@
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -423,20 +503,28 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
-* in columns k+1:n
+* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J + 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length N-J+1
+* of the rows to swap back doesn't include diagonal element)
J = J + 1
- END IF
- J = J + 1
- IF( JP.NE.JJ .AND. J.LE.N )
- $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
- IF( J.LE.N )
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
@@ -473,7 +561,7 @@
ABSAKK = CABS1( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
@@ -484,7 +572,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
-* Column K is zero: set INFO and continue
+* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -528,7 +616,7 @@
*
KP = IMAX
*
-* copy column K+1 of W to column K
+* copy column K+1 of W to column K of W
*
CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
@@ -540,22 +628,36 @@
KSTEP = 2
END IF
END IF
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
-* Updated column KP is already stored in column KK of W
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
-* Copy non-updated column KK to column KP
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
*
- A( KP, K ) = A( KK, K )
- CALL ZCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
- CALL ZCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+ A( KP, KP ) = A( KK, KK )
+ CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ IF( KP.LT.N )
+ $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
-* Interchange rows KK and KP in first KK columns of A and W
+* Interchange rows KK and KP in first K-1 columns of A
+* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
*
- CALL ZSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ IF( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@@ -563,17 +665,23 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
-* W(k) = L(k)*D(k)
+* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
-* Store L(k) in column k of A
+* Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = CONE / A( K, K )
CALL ZSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
+*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@@ -582,16 +690,52 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
+*
+* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored)
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
-* Store L(k) and L(k+1) in columns k and k+1 of A
+* Compose the columns of the inverse of 2-by-2 pivot
+* block D in the following way to reduce the number
+* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
+* this inverse
+*
+* D**(-1) = ( d11 d21 )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
+* ( (-d21 ) ( d11 ) )
+*
+* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
+*
+* * ( ( d22/d21 ) ( -1 ) ) =
+* ( ( -1 ) ( d11/d21 ) )
+*
+* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = 1/d21 * T * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
+*
+* = D21 * ( ( D11 ) ( -1 ) )
+* ( ( -1 ) ( D22 ) )
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
@@ -603,7 +747,9 @@
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
+*
END IF
+*
END IF
*
* Store details of the interchanges in IPIV
@@ -648,20 +794,28 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
-* in columns 1:k-1
+* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
- JJ = J
- JP = IPIV( J )
- IF( JP.LT.0 ) THEN
- JP = -JP
+*
+* Undo the interchanges (if any) of rows JJ and JP at each
+* step J
+*
+* (Here, J is a diagonal index)
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+* (Here, J is a diagonal index)
+ J = J - 1
+ END IF
+* (NOTE: Here, J is used to determine row length. Length J
+* of the rows to swap back doesn't include diagonal element)
J = J - 1
- END IF
- J = J - 1
- IF( JP.NE.JJ .AND. J.GE.1 )
- $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
- IF( J.GE.1 )
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
diff --git a/lapack-netlib/SRC/zlasyf_rook.f b/lapack-netlib/SRC/zlasyf_rook.f
new file mode 100644
index 000000000..108c03e6b
--- /dev/null
+++ b/lapack-netlib/SRC/zlasyf_rook.f
@@ -0,0 +1,900 @@
+*> \brief \b ZLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLASYF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLASYF_ROOK computes a partial factorization of a complex symmetric
+*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> ZLASYF_ROOK is an auxiliary routine called by ZSYTRF_ROOK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*> On exit, A contains details of the partial factorization.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CONE, CZERO
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
+ $ CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK,
+ $ KW, KKW, KP, KSTEP, P, II
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, DTEMP, SFMIN
+ COMPLEX*16 D11, D12, D21, D22, R1, T, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IZAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZCOPY, ZGEMM, ZGEMV, ZSCAL, ZSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT, DIMAG, DBLE
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL ZCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL ZGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ DTEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL ZCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL ZCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL ZSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL ZCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL ZCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL ZSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL ZSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = CONE / ( D11*D22-CONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in columns k+1:n
+*
+ J = K + 1
+ 60 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J + 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J + 1
+ IF( JP2.NE.JJ .AND. J.LE.N )
+ $ CALL ZSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
+ JJ = J - 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL ZSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LE.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ DTEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL ZCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL ZCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL ZSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL ZCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL ZCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL ZSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL ZSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
+ $ CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* in columns 1:k-1
+*
+ J = K - 1
+ 120 CONTINUE
+*
+ KSTEP = 1
+ JP1 = 1
+ JJ = J
+ JP2 = IPIV( J )
+ IF( JP2.LT.0 ) THEN
+ JP2 = -JP2
+ J = J - 1
+ JP1 = -IPIV( J )
+ KSTEP = 2
+ END IF
+*
+ J = J - 1
+ IF( JP2.NE.JJ .AND. J.GE.1 )
+ $ CALL ZSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
+ JJ = J + 1
+ IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
+ $ CALL ZSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GE.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of ZLASYF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zstemr.f b/lapack-netlib/SRC/zstemr.f
index 5333951db..770706e58 100644
--- a/lapack-netlib/SRC/zstemr.f
+++ b/lapack-netlib/SRC/zstemr.f
@@ -311,7 +311,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -329,10 +329,10 @@
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
@@ -408,7 +408,8 @@
WU = ZERO
IIL = 0
IIU = 0
-
+ NSPLIT = 0
+
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
* The interval (WL, WU] contains all the wanted eigenvalues.
diff --git a/lapack-netlib/SRC/zsycon_rook.f b/lapack-netlib/SRC/zsycon_rook.f
new file mode 100644
index 000000000..074eeab38
--- /dev/null
+++ b/lapack-netlib/SRC/zsycon_rook.f
@@ -0,0 +1,255 @@
+*> \brief \b ZSYCON_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYCON_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND,
+* WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYCON_ROOK estimates the reciprocal of the condition number (in the
+*> 1-norm) of a complex symmetric matrix A using the factorization
+*> A = U*D*U**T or A = L*D*L**T computed by ZSYTRF_ROOK.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is DOUBLE PRECISION
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is DOUBLE PRECISION
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (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
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLACN2, ZSYTRS_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYCON_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL ZSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of ZSYCON_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zsysv_rook.f b/lapack-netlib/SRC/zsysv_rook.f
new file mode 100644
index 000000000..9304a3d29
--- /dev/null
+++ b/lapack-netlib/SRC/zsysv_rook.f
@@ -0,0 +1,293 @@
+*> \brief ZSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYSV_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+* LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYSV_ROOK computes the solution to a complex system of linear
+*> equations
+*> A * X = B,
+*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*> matrices.
+*>
+*> The diagonal pivoting method is used to factor A as
+*> A = U * D * U**T, if UPLO = 'U', or
+*> A = L * D * L**T, if UPLO = 'L',
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> ZSYTRF_ROOK is called to compute the factorization of a complex
+*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
+*> pivoting method.
+*>
+*> The factored form of A is then used to solve the system
+*> of equations A * X = B by calling ZSYTRS_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order of the
+*> matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, if INFO = 0, the block diagonal matrix D and the
+*> multipliers used to obtain the factor U or L from the
+*> factorization A = U*D*U**T or A = L*D*L**T as computed by
+*> ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by ZSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \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 length of WORK. LWORK >= 1, and for best performance
+*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+*> ZSYTRF_ROOK.
+*>
+*> TRS will be done with Level 2 BLAS
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, so the solution could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complex16SYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZSYTRF_ROOK, ZSYTRS_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYSV_ROOK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**T or A = L*D*L**T.
+*
+ CALL ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+* Solve with TRS_ROOK ( Use Level 2 BLAS)
+*
+ CALL ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of ZSYSV_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zsytf2.f b/lapack-netlib/SRC/zsytf2.f
index cf604ecfe..f244ba6b5 100644
--- a/lapack-netlib/SRC/zsytf2.f
+++ b/lapack-netlib/SRC/zsytf2.f
@@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
-*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-*> interchanged and D(k,k) is a 1-by-1 diagonal block.
-*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
+*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*> is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
+*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
+*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex16SYcomputational
*
@@ -182,10 +191,10 @@
* =====================================================================
SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
-* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -273,7 +282,8 @@
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, A( 1, K ), 1 )
@@ -284,7 +294,8 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN
*
-* Column K is zero or NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@@ -441,7 +452,8 @@
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
-* column K, and COLMAX is its absolute value
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
@@ -452,7 +464,8 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN
*
-* Column K is zero or NaN: set INFO and continue
+* Column K is zero or underflow, or contains a NaN:
+* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
diff --git a/lapack-netlib/SRC/zsytf2_rook.f b/lapack-netlib/SRC/zsytf2_rook.f
new file mode 100644
index 000000000..cf964ae8b
--- /dev/null
+++ b/lapack-netlib/SRC/zsytf2_rook.f
@@ -0,0 +1,821 @@
+*> \brief \b ZSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTF2_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYTF2_ROOK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, U**T is the transpose of U, and D is symmetric and
+*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> n-by-n upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading n-by-n lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2013, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CONE
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, DTEMP, SFMIN
+ COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IZAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT, DIMAG, DBLE
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTF2_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL ZSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL ZSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL ZSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of ZSYTF2_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zsytrf_rook.f b/lapack-netlib/SRC/zsytrf_rook.f
new file mode 100644
index 000000000..718a2815b
--- /dev/null
+++ b/lapack-netlib/SRC/zsytrf_rook.f
@@ -0,0 +1,393 @@
+*> \brief \b ZSYTRF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTRF_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYTRF_ROOK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
+*> The form of the factorization is
+*>
+*> A = U*D*U**T or A = L*D*L**T
+*>
+*> where U (or L) is a product of permutation and unit upper (lower)
+*> triangular matrices, and D is symmetric and block diagonal with
+*> 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
+*> N-by-N upper triangular part of A contains the upper
+*> triangular part of the matrix A, and the strictly lower
+*> triangular part of A is not referenced. If UPLO = 'L', the
+*> leading N-by-N lower triangular part of A contains the lower
+*> triangular part of the matrix A, and the strictly upper
+*> triangular part of A is not referenced.
+*>
+*> On exit, the block diagonal matrix D and the multipliers used
+*> to obtain the factor U or L (see below for further details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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, D(i,i) is exactly zero. The factorization
+*> has been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if it
+*> is used to solve a system of equations.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> If UPLO = 'U', then A = U*D*U**T, where
+*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I v 0 ) k-s
+*> U(k) = ( 0 I 0 ) s
+*> ( 0 0 I ) n-k
+*> k-s s n-k
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*>
+*> If UPLO = 'L', then A = L*D*L**T, where
+*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*>
+*> ( I 0 0 ) k-1
+*> L(k) = ( 0 I 0 ) s
+*> ( 0 v I ) n-k-s+1
+*> k-1 s n-k-s+1
+*>
+*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLASYF_ROOK, ZSYTF2_ROOK, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'ZSYTRF_ROOK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTRF_ROOK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'ZSYTRF_ROOK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by ZLASYF_ROOK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL ZLASYF_ROOK( UPLO, K, NB, KB, A, LDA,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL ZSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by ZLASYF_ROOK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL ZLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL ZSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
+ $ IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of ZSYTRF_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zsytri_rook.f b/lapack-netlib/SRC/zsytri_rook.f
new file mode 100644
index 000000000..5a9631e8e
--- /dev/null
+++ b/lapack-netlib/SRC/zsytri_rook.f
@@ -0,0 +1,451 @@
+*> \brief \b ZSYTRI_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTRI_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYTRI_ROOK computes the inverse of a complex symmetric
+*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
+*> computed by ZSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the block diagonal matrix D and the multipliers
+*> used to obtain the factor U or L as computed by ZSYTRF_ROOK.
+*>
+*> On exit, if INFO = 0, the (symmetric) inverse of the original
+*> matrix. If UPLO = 'U', the upper triangular part of the
+*> inverse is formed and the part of A below the diagonal is not
+*> referenced; if UPLO = 'L' the lower triangular part of the
+*> inverse is formed and the part of A above the diagonal is
+*> not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (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, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 CONE, CZERO
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
+ $ CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KP, KSTEP
+ COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ COMPLEX*16 ZDOTU
+ EXTERNAL LSAME, ZDOTU
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZCOPY, ZSWAP, ZSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTRI_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = CONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL ZSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = A( K, K+1 )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-CONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL ZSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ ZDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL ZSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ ZDOTU( K-1, WORK, 1, A( 1, K+1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K+1 with -IPIV(K) and
+* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+*
+ K = K + 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K + 1
+ GO TO 30
+ 40 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L**T.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 50 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = CONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL ZSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = A( K, K-1 )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-CONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL ZSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ CZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ ZDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL ZSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ CZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ ZDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* Interchange rows and columns K and IPIV(K) in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ KP = IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ ELSE
+*
+* Interchange rows and columns K and K-1 with -IPIV(K) and
+* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+*
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+*
+ K = K - 1
+ KP = -IPIV( K )
+ IF( KP.NE.K ) THEN
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ END IF
+ END IF
+*
+ K = K - 1
+ GO TO 50
+ 60 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZSYTRI_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/zsytrs_rook.f b/lapack-netlib/SRC/zsytrs_rook.f
new file mode 100644
index 000000000..a68abdb83
--- /dev/null
+++ b/lapack-netlib/SRC/zsytrs_rook.f
@@ -0,0 +1,484 @@
+*> \brief \b ZSYTRS_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTRS_ROOK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYTRS_ROOK solves a system of linear equations A*X = B with
+*> a complex symmetric matrix A using the factorization A = U*D*U**T or
+*> A = L*D*L**T computed by ZSYTRF_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are stored
+*> as an upper or lower triangular matrix.
+*> = 'U': Upper triangular, form is A = U*D*U**T;
+*> = 'L': Lower triangular, form is A = L*D*L**T.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of columns
+*> of the matrix B. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2011, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 CONE
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEMV, ZGERU, ZSCAL, ZSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTRS_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL ZGERU( K-1, NRHS, -CONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL ZSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.GT.2 ) THEN
+ CALL ZGERU( K-2, NRHS,-CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL ZGERU( K-2, NRHS,-CONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / AKM1K
+ DENOM = AKM1*AK - CONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U**T *X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U**T(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.GT.1 )
+ $ CALL ZGEMV( 'Transpose', K-1, NRHS, -CONE, B,
+ $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.GT.1 ) THEN
+ CALL ZGEMV( 'Transpose', K-1, NRHS, -CONE, B,
+ $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Transpose', K-1, NRHS, -CONE, B,
+ $ LDB, A( 1, K+1 ), 1, CONE, B( K+1, 1 ), LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL ZGERU( N-K, NRHS, -CONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL ZSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K+1 )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL ZGERU( N-K-1, NRHS,-CONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL ZGERU( N-K-1, NRHS,-CONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / AKM1K
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - CONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L**T *X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L**T(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL ZGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL ZGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K-1 ), 1, CONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ KP = -IPIV( K-1 )
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZSYTRS_ROOK
+*
+ END
diff --git a/lapack-netlib/SRC/ztpmqrt.f b/lapack-netlib/SRC/ztpmqrt.f
index 684f6d938..87ae54172 100644
--- a/lapack-netlib/SRC/ztpmqrt.f
+++ b/lapack-netlib/SRC/ztpmqrt.f
@@ -175,7 +175,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -216,10 +216,10 @@
SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
$ A, LDA, B, LDB, WORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@@ -235,7 +235,7 @@
* ..
* .. Local Scalars ..
LOGICAL LEFT, RIGHT, TRAN, NOTRAN
- INTEGER I, IB, MB, LB, KF, Q
+ INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -257,10 +257,12 @@
TRAN = LSAME( TRANS, 'C' )
NOTRAN = LSAME( TRANS, 'N' )
*
- IF( LEFT ) THEN
- Q = M
+ IF ( LEFT ) THEN
+ LDVQ = MAX( 1, M )
+ LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
- Q = N
+ LDVQ = MAX( 1, N )
+ LDAQ = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
INFO = -1
@@ -274,13 +276,13 @@
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
INFO = -6
- ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
- ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
+ ELSE IF( LDV.LT.LDVQ ) THEN
INFO = -9
ELSE IF( LDT.LT.NB ) THEN
INFO = -11
- ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ ELSE IF( LDA.LT.LDAQ ) THEN
INFO = -13
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -15
diff --git a/lapack-netlib/SRC/ztpqrt.f b/lapack-netlib/SRC/ztpqrt.f
index ac15f83bc..05fc88448 100644
--- a/lapack-netlib/SRC/ztpqrt.f
+++ b/lapack-netlib/SRC/ztpqrt.f
@@ -132,7 +132,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -189,10 +189,10 @@
SUBROUTINE ZTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK,
$ INFO )
*
-* -- LAPACK computational routine (version 3.4.1) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDT, N, M, L, NB
@@ -219,9 +219,9 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
- ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
INFO = -3
- ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN
+ ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
diff --git a/lapack-netlib/SRC/zunbdb.f b/lapack-netlib/SRC/zunbdb.f
index 24555401b..618c0a0d4 100644
--- a/lapack-netlib/SRC/zunbdb.f
+++ b/lapack-netlib/SRC/zunbdb.f
@@ -255,7 +255,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -287,10 +287,10 @@
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIGNS, TRANS
@@ -314,7 +314,7 @@
* ..
* .. Local Scalars ..
LOGICAL COLMAJOR, LQUERY
- INTEGER I, LWORKMIN, LWORKOPT
+ INTEGER I, LWORKMIN, LWORKOPT, PI1, QI1
DOUBLE PRECISION Z1, Z2, Z3, Z4
* ..
* .. External Subroutines ..
@@ -420,19 +420,33 @@
THETA(I) = ATAN2( DZNRM2( M-P-I+1, X21(I,I), 1 ),
$ DZNRM2( P-I+1, X11(I,I), 1 ) )
*
- CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( P .GT. I ) THEN
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ ELSE IF ( P .EQ. I ) THEN
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
+ END IF
X11(I,I) = ONE
- CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF ( M-P .GT. I ) THEN
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
+ $ TAUP2(I) )
+ ELSE IF ( M-P .EQ. I ) THEN
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
+ $ TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
- CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK )
- CALL ZLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
- $ DCONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
- CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1,
- $ DCONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK )
- CALL ZLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
- $ DCONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
+ IF ( Q .GT. I ) THEN
+ CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1,
+ $ DCONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK )
+ CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ DCONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK )
+ END IF
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL ZLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
+ $ DCONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
+ CALL ZLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
+ $ DCONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q ) THEN
CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), 0.0D0 ),
@@ -451,13 +465,25 @@
*
IF( I .LT. Q ) THEN
CALL ZLACGV( Q-I, X11(I,I+1), LDX11 )
- CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
- $ TAUQ1(I) )
+ IF ( I .EQ. Q-1 ) THEN
+ CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11,
+ $ TAUQ1(I) )
+ ELSE
+ CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
+ $ TAUQ1(I) )
+ END IF
X11(I,I+1) = ONE
END IF
- CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
- CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( M-Q+1 .GT. I ) THEN
+ CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
+ IF ( M-Q .EQ. I ) THEN
+ CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
+ END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@@ -466,10 +492,14 @@
CALL ZLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
END IF
- CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
- CALL ZLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X22(I+1,I), LDX22, WORK )
+ IF ( P .GT. I ) THEN
+ CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
+ IF ( M-P .GT. I ) THEN
+ CALL ZLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
+ END IF
*
IF( I .LT. Q )
$ CALL ZLACGV( Q-I, X11(I,I+1), LDX11 )
@@ -484,12 +514,19 @@
CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I),
$ LDX12 )
CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
- CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
- $ TAUQ2(I) )
+ IF ( I .GE. M-Q ) THEN
+ CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
+ $ TAUQ2(I) )
+ ELSE
+ CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
+ $ TAUQ2(I) )
+ END IF
X12(I,I) = ONE
*
- CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ IF ( P .GT. I ) THEN
+ CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL ZLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
@@ -548,8 +585,13 @@
*
CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
X11(I,I) = ONE
- CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
- $ TAUP2(I) )
+ IF ( I .EQ. M-P ) THEN
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
+ $ TAUP2(I) )
+ ELSE
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
+ $ TAUP2(I) )
+ END IF
X21(I,I) = ONE
*
CALL ZLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
@@ -594,8 +636,10 @@
END IF
CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
$ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
- CALL ZLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
- $ DCONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
+ IF ( M-P .GT. I ) THEN
+ CALL ZLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
+ $ DCONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
+ END IF
*
END DO
*
@@ -607,8 +651,10 @@
CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
X12(I,I) = ONE
*
- CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
- $ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
+ IF ( P .GT. I ) THEN
+ CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
+ END IF
IF( M-P-Q .GE. 1 )
$ CALL ZLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
$ DCONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK )
@@ -625,9 +671,11 @@
$ TAUQ2(P+I) )
X22(P+I,Q+I) = ONE
*
- CALL ZLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
- $ DCONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22,
- $ WORK )
+ IF ( M-P-Q .NE. I ) THEN
+ CALL ZLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
+ $ DCONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22,
+ $ WORK )
+ END IF
*
END DO
*
diff --git a/lapack-netlib/SRC/zunbdb1.f b/lapack-netlib/SRC/zunbdb1.f
new file mode 100644
index 000000000..4125450c7
--- /dev/null
+++ b/lapack-netlib/SRC/zunbdb1.f
@@ -0,0 +1,328 @@
+*> \brief \b ZUNBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines ZUNBDB2, ZUNBDB3, and ZUNBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ PARAMETER ( ONE = (1.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, XERBLA
+ EXTERNAL ZLACGV
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( DBLE( X21(I,I) ), DBLE( X11(I,I) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL ZDROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
+ $ S )
+ CALL ZLACGV( Q-I, X21(I,I+1), LDX21 )
+ CALL ZLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = DBLE( X21(I,I+1) )
+ X21(I,I+1) = ONE
+ CALL ZLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I, X21(I,I+1), LDX21 )
+ C = SQRT( DZNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL ZUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB1
+*
+ END
+
diff --git a/lapack-netlib/SRC/zunbdb2.f b/lapack-netlib/SRC/zunbdb2.f
new file mode 100644
index 000000000..89104f650
--- /dev/null
+++ b/lapack-netlib/SRC/zunbdb2.f
@@ -0,0 +1,336 @@
+*> \brief \b ZUNBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB3, and ZUNBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 NEGONE, ONE
+ PARAMETER ( NEGONE = (-1.0D0,0.0D0),
+ $ ONE = (1.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C,
+ $ S )
+ END IF
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = DBLE( X11(I,I) )
+ X11(I,I) = ONE
+ CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DZNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL ZUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL ZSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL ZLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( DBLE( X11(I+1,I) ), DBLE( X21(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL ZLARF( 'L', P-I, Q-I, X11(I+1,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB2
+*
+ END
+
diff --git a/lapack-netlib/SRC/zunbdb3.f b/lapack-netlib/SRC/zunbdb3.f
new file mode 100644
index 000000000..37a5c89f4
--- /dev/null
+++ b/lapack-netlib/SRC/zunbdb3.f
@@ -0,0 +1,336 @@
+*> \brief \b ZUNBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB3 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ PARAMETER ( ONE = (1.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL ZDROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C,
+ $ S )
+ END IF
+*
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = DBLE( X21(I,I) )
+ X21(I,I) = ONE
+ CALL ZLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ C = SQRT( DZNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL ZUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL ZLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( DBLE( X21(I+1,I) ), DBLE( X11(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL ZLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1,
+ $ DCONJG(TAUP2(I)), X21(I+1,I+1), LDX21,
+ $ WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB3
+*
+ END
+
diff --git a/lapack-netlib/SRC/zunbdb4.f b/lapack-netlib/SRC/zunbdb4.f
new file mode 100644
index 000000000..91ed9d052
--- /dev/null
+++ b/lapack-netlib/SRC/zunbdb4.f
@@ -0,0 +1,385 @@
+*> \brief \b ZUNBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB4 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is COMPLEX*16 array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0D0,0.0D0), ONE = (1.0D0,0.0D0),
+ $ ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL ZUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL ZSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL ZLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL ZLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( DBLE( PHANTOM(1) ), DBLE( PHANTOM(P+1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL ZLARF( 'L', P, Q, PHANTOM(1), 1, DCONJG(TAUP1(1)), X11,
+ $ LDX11, WORK(ILARF) )
+ CALL ZLARF( 'L', M-P, Q, PHANTOM(P+1), 1, DCONJG(TAUP2(1)),
+ $ X21, LDX21, WORK(ILARF) )
+ ELSE
+ CALL ZUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL ZSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL ZLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL ZLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( DBLE( X11(I,I-1) ), DBLE( X21(I,I-1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ DCONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ DCONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = DBLE( X21(I,I) )
+ X21(I,I) = ONE
+ CALL ZLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ CALL ZLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL ZLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB4
+*
+ END
+
diff --git a/lapack-netlib/SRC/zunbdb5.f b/lapack-netlib/SRC/zunbdb5.f
new file mode 100644
index 000000000..f777324b7
--- /dev/null
+++ b/lapack-netlib/SRC/zunbdb5.f
@@ -0,0 +1,274 @@
+*> \brief \b ZUNBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB5 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX*16 array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX*16 array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX*16 array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX*16 array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZUNBDB6, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( DZNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DZNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DZNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB5
+*
+ END
+
diff --git a/lapack-netlib/SRC/zunbdb6.f b/lapack-netlib/SRC/zunbdb6.f
new file mode 100644
index 000000000..931710d06
--- /dev/null
+++ b/lapack-netlib/SRC/zunbdb6.f
@@ -0,0 +1,313 @@
+*> \brief \b ZUNBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB6 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX*16 array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX*16 array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX*16 array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX*16 array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0,
+ $ REALZERO = 0.0D0 )
+ COMPLEX*16 NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0D0,0.0D0), ONE = (1.0D0,0.0D0),
+ $ ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEMV, ZLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL ZLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL ZGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL ZGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL ZGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL ZGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL ZLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL ZGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL ZGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL ZGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL ZGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of ZUNBDB6
+*
+ END
+
diff --git a/lapack-netlib/SRC/zuncsd.f b/lapack-netlib/SRC/zuncsd.f
index 3f7861d2a..18982f8ff 100644
--- a/lapack-netlib/SRC/zuncsd.f
+++ b/lapack-netlib/SRC/zuncsd.f
@@ -308,7 +308,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
@@ -320,10 +320,10 @@
$ LDV2T, WORK, LWORK, RWORK, LRWORK,
$ IWORK, INFO )
*
-* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS
@@ -356,7 +356,7 @@
$ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN,
$ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN,
$ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN,
- $ LORGQRWORKOPT, LWORKMIN, LWORKOPT
+ $ LORGQRWORKOPT, LWORKMIN, LWORKOPT, P1, Q1
LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2,
$ WANTV1T, WANTV2T
INTEGER LRWORKMIN, LRWORKOPT
@@ -371,7 +371,7 @@
EXTERNAL LSAME
* ..
* .. Intrinsic Functions
- INTRINSIC COS, INT, MAX, MIN, SIN
+ INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
@@ -392,9 +392,22 @@
INFO = -8
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -9
- ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR.
- $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN
- INFO = -11
+ ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -11
+ ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN
+ INFO = -11
+ ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN
+ INFO = -13
+ ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -13
+ ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -15
+ ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN
+ INFO = -15
+ ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -17
+ ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN
+ INFO = -17
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -20
ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN
@@ -458,9 +471,10 @@
IB22D = IB21E + MAX( 1, Q - 1 )
IB22E = IB22D + MAX( 1, Q )
IBBCSD = IB22E + MAX( 1, Q - 1 )
- CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0,
- $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0,
- $ 0, 0, 0, 0, 0, 0, 0, RWORK, -1, CHILDINFO )
+ CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q,
+ $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T,
+ $ V2T, LDV2T, THETA, THETA, THETA, THETA, THETA,
+ $ THETA, THETA, THETA, RWORK, -1, CHILDINFO )
LBBCSDWORKOPT = INT( RWORK(1) )
LBBCSDWORKMIN = LBBCSDWORKOPT
LRWORKOPT = IBBCSD + LBBCSDWORKOPT - 1
@@ -474,19 +488,19 @@
ITAUQ1 = ITAUP2 + MAX( 1, M - P )
ITAUQ2 = ITAUQ1 + MAX( 1, Q )
IORGQR = ITAUQ2 + MAX( 1, M - Q )
- CALL ZUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
+ CALL ZUNGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGQRWORKOPT = INT( WORK(1) )
LORGQRWORKMIN = MAX( 1, M - Q )
IORGLQ = ITAUQ2 + MAX( 1, M - Q )
- CALL ZUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
+ CALL ZUNGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGLQWORKOPT = INT( WORK(1) )
LORGLQWORKMIN = MAX( 1, M - Q )
IORBDB = ITAUQ2 + MAX( 1, M - Q )
CALL ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
- $ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK,
- $ -1, CHILDINFO )
+ $ X21, LDX21, X22, LDX22, THETA, THETA, U1, U2,
+ $ V1T, V2T, WORK, -1, CHILDINFO )
LORBDBWORKOPT = INT( WORK(1) )
LORBDBWORKMIN = LORBDBWORKOPT
LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT,
@@ -551,10 +565,14 @@
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
CALL ZLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T )
- CALL ZLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
- $ V2T(P+1,P+1), LDV2T )
- CALL ZUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
- $ WORK(IORGLQ), LORGLQWORK, INFO )
+ IF( M-P .GT. Q) THEN
+ CALL ZLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
+ $ V2T(P+1,P+1), LDV2T )
+ END IF
+ IF( M .GT. Q ) THEN
+ CALL ZUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
+ $ WORK(IORGLQ), LORGLQWORK, INFO )
+ END IF
END IF
ELSE
IF( WANTU1 .AND. P .GT. 0 ) THEN
@@ -579,9 +597,13 @@
$ WORK(IORGQR), LORGQRWORK, INFO )
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
+ P1 = MIN( P+1, M )
+ Q1 = MIN( Q+1, M )
CALL ZLACPY( 'L', M-Q, P, X12, LDX12, V2T, LDV2T )
- CALL ZLACPY( 'L', M-P-Q, M-P-Q, X22(P+1,Q+1), LDX22,
- $ V2T(P+1,P+1), LDV2T )
+ IF( M .GT. P+Q ) THEN
+ CALL ZLACPY( 'L', M-P-Q, M-P-Q, X22(P1,Q1), LDX22,
+ $ V2T(P+1,P+1), LDV2T )
+ END IF
CALL ZUNGQR( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
$ WORK(IORGQR), LORGQRWORK, INFO )
END IF
diff --git a/lapack-netlib/SRC/zuncsd2by1.f b/lapack-netlib/SRC/zuncsd2by1.f
new file mode 100644
index 000000000..777f132e7
--- /dev/null
+++ b/lapack-netlib/SRC/zuncsd2by1.f
@@ -0,0 +1,756 @@
+*> \brief \b ZUNCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNCSD2BY1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION RWORK(*)
+* DOUBLE PRECISION THETA(*)
+* COMPLEX*16 U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is COMPLEX*16 array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is COMPLEX*16 array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is COMPLEX*16 array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is COMPLEX*16 array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \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.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*> \verbatim
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \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.
+*> If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LRWORK
+*> \verbatim
+*> LRWORK is INTEGER
+*> The dimension of the array RWORK.
+*>
+*> If LRWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the RWORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LRWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: ZBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+ INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION RWORK(*)
+ DOUBLE PRECISION THETA(*)
+ COMPLEX*16 U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZBBCSD, ZCOPY, ZLACPY, ZLAPMR, ZLAPMT, ZUNBDB1,
+ $ ZUNBDB2, ZUNBDB3, ZUNBDB4, ZUNGLQ, ZUNGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-----------------------------------------|
+* | LWORKOPT (1) |
+* |-----------------------------------------|
+* | TAUP1 (MAX(1,P)) |
+* | TAUP2 (MAX(1,M-P)) |
+* | TAUQ1 (MAX(1,Q)) |
+* |-----------------------------------------|
+* | ZUNBDB WORK | ZUNGQR WORK | ZUNGLQ WORK |
+* | | | |
+* | | | |
+* | | | |
+* | | | |
+* |-----------------------------------------|
+* RWORK layout:
+* |------------------|
+* | LRWORKOPT (1) |
+* |------------------|
+* | PHI (MAX(1,R-1)) |
+* |------------------|
+* | B11D (R) |
+* | B11E (R-1) |
+* | B12D (R) |
+* | B12E (R-1) |
+* | B21D (R) |
+* | B21E (R-1) |
+* | B22D (R) |
+* | B22E (R-1) |
+* | ZBBCSD RWORK |
+* |------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + MAX( 1, R )
+ IB12D = IB11E + MAX( 1, R - 1 )
+ IB12E = IB12D + MAX( 1, R )
+ IB21D = IB12E + MAX( 1, R - 1 )
+ IB21E = IB21D + MAX( 1, R )
+ IB22D = IB21E + MAX( 1, R - 1 )
+ IB22E = IB22D + MAX( 1, R )
+ IBBCSD = IB22E + MAX( 1, R - 1 )
+ ITAUP1 = 2
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE
+ CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL ZUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ END IF
+ LRWORKMIN = IBBCSD+LBBCSD-1
+ LRWORKOPT = LRWORKMIN
+ RWORK(1) = LRWORKOPT
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL ZUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL ZLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL ZUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL ZLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL ZLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL ZLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL ZLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL ZUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL ZLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL ZLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2,
+ $ U1, LDU1, RWORK(IB11D), RWORK(IB11E),
+ $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D),
+ $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E),
+ $ RWORK(IBBCSD), LBBCSD, CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL ZLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL ZLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL ZCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL ZLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL ZUNGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL ZCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL ZLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL ZLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL ZLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL ZLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL ZLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL ZLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZUNCSD2BY1
+*
+ END
+
diff --git a/lapack-netlib/TESTING/EIG/alahdg.f b/lapack-netlib/TESTING/EIG/alahdg.f
index 1431d8ee0..51959416c 100644
--- a/lapack-netlib/TESTING/EIG/alahdg.f
+++ b/lapack-netlib/TESTING/EIG/alahdg.f
@@ -209,14 +209,23 @@
*
* CSD
*
- WRITE( IOUNIT, FMT = 9920 )1
- WRITE( IOUNIT, FMT = 9921 )2
- WRITE( IOUNIT, FMT = 9922 )3
- WRITE( IOUNIT, FMT = 9923 )4
- WRITE( IOUNIT, FMT = 9924 )5
- WRITE( IOUNIT, FMT = 9925 )6
- WRITE( IOUNIT, FMT = 9926 )7
- WRITE( IOUNIT, FMT = 9927 )8
+ WRITE( IOUNIT, FMT = 9910 )
+ WRITE( IOUNIT, FMT = 9911 )1
+ WRITE( IOUNIT, FMT = 9912 )2
+ WRITE( IOUNIT, FMT = 9913 )3
+ WRITE( IOUNIT, FMT = 9914 )4
+ WRITE( IOUNIT, FMT = 9915 )5
+ WRITE( IOUNIT, FMT = 9916 )6
+ WRITE( IOUNIT, FMT = 9917 )7
+ WRITE( IOUNIT, FMT = 9918 )8
+ WRITE( IOUNIT, FMT = 9919 )9
+ WRITE( IOUNIT, FMT = 9920 )
+ WRITE( IOUNIT, FMT = 9921 )10
+ WRITE( IOUNIT, FMT = 9922 )11
+ WRITE( IOUNIT, FMT = 9923 )12
+ WRITE( IOUNIT, FMT = 9924 )13
+ WRITE( IOUNIT, FMT = 9925 )14
+ WRITE( IOUNIT, FMT = 9926 )15
END IF
*
9999 FORMAT( 1X, A )
@@ -291,18 +300,29 @@
*
* CSD test ratio
*
- 9920 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)',
+ 9910 FORMAT( 3X, '2-by-2 CSD' )
+ 9911 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)',
$ ' * max(norm(I-X''*X),EPS) )' )
- 9921 FORMAT( 3X, I2, ': norm( U1'' * X12 * V2-(-S)) / ( max( P,',
+ 9912 FORMAT( 3X, I2, ': norm( U1'' * X12 * V2-(-S)) / ( max( P,',
$ 'M-Q) * max(norm(I-X''*X),EPS) )' )
- 9922 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max(M-P,',
+ 9913 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max(M-P,',
$ ' Q) * max(norm(I-X''*X),EPS) )' )
- 9923 FORMAT( 3X, I2, ': norm( U2'' * X22 * V2 - C ) / ( max(M-P,',
+ 9914 FORMAT( 3X, I2, ': norm( U2'' * X22 * V2 - C ) / ( max(M-P,',
$ 'M-Q) * max(norm(I-X''*X),EPS) )' )
- 9924 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' )
- 9925 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' )
- 9926 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' )
- 9927 FORMAT( 3X, I2, ': norm( I - V2''*V2 ) / ( (M-Q) * EPS )' )
+ 9915 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' )
+ 9916 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' )
+ 9917 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' )
+ 9918 FORMAT( 3X, I2, ': norm( I - V2''*V2 ) / ( (M-Q) * EPS )' )
+ 9919 FORMAT( 3X, I2, ': principal angle ordering ( 0 or ULP )' )
+ 9920 FORMAT( 3X, '2-by-1 CSD' )
+ 9921 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)',
+ $ ' * max(norm(I-X''*X),EPS) )' )
+ 9922 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max( M-P,',
+ $ 'Q) * max(norm(I-X''*X),EPS) )' )
+ 9923 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' )
+ 9924 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' )
+ 9925 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' )
+ 9926 FORMAT( 3X, I2, ': principal angle ordering ( 0 or ULP )' )
RETURN
*
* End of ALAHDG
diff --git a/lapack-netlib/TESTING/EIG/cchkee.f b/lapack-netlib/TESTING/EIG/cchkee.f
index f310f7988..31715d568 100644
--- a/lapack-netlib/TESTING/EIG/cchkee.f
+++ b/lapack-netlib/TESTING/EIG/cchkee.f
@@ -1026,17 +1026,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex_eig
*
* =====================================================================
PROGRAM CCHKEE
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* =====================================================================
*
@@ -1129,6 +1129,10 @@
* ..
* .. Executable Statements ..
*
+ A = 0.0
+ B = 0.0
+ C = 0.0
+ DC = 0.0
S1 = SECOND( )
FATAL = .FALSE.
NUNIT = NOUT
diff --git a/lapack-netlib/TESTING/EIG/cckcsd.f b/lapack-netlib/TESTING/EIG/cckcsd.f
index c6cb13b06..a4146c743 100644
--- a/lapack-netlib/TESTING/EIG/cckcsd.f
+++ b/lapack-netlib/TESTING/EIG/cckcsd.f
@@ -205,13 +205,16 @@
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- REAL GAPDIGIT, ORTH, PIOVER2, TEN
+ PARAMETER ( NTYPES = 4 )
+ REAL GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN
PARAMETER ( GAPDIGIT = 10.0E0, ORTH = 1.0E-4,
$ PIOVER2 = 1.57079632679489662E0,
- $ TEN = 10.0D0 )
+ $ REALONE = 1.0E0, REALZERO = 0.0E0,
+ $ TEN = 10.0E0 )
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
@@ -231,8 +234,8 @@
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- REAL SLARND
- EXTERNAL SLARND
+ REAL SLARAN, SLARND
+ EXTERNAL SLARAN, SLARND
* ..
* .. Executable Statements ..
*
@@ -286,7 +289,7 @@
$ ORTH*SLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-SLARND(1,ISEED)*GAPDIGIT)
@@ -298,9 +301,18 @@
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL CLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL CLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( SLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL CSROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX),
+ $ 1, REALZERO, REALONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
diff --git a/lapack-netlib/TESTING/EIG/ccsdts.f b/lapack-netlib/TESTING/EIG/ccsdts.f
index da6ac6b75..bdb85b832 100644
--- a/lapack-netlib/TESTING/EIG/ccsdts.f
+++ b/lapack-netlib/TESTING/EIG/ccsdts.f
@@ -17,7 +17,7 @@
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* REAL RESULT( 9 ), RWORK( * ), THETA( * )
+* REAL RESULT( 15 ), RWORK( * ), THETA( * )
* COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
@@ -47,6 +47,21 @@
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also SORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
@@ -171,8 +186,9 @@
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is REAL array, dimension (9)
+*> RESULT is REAL array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
@@ -184,6 +200,15 @@
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
@@ -214,7 +239,7 @@
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- REAL RESULT( 9 ), RWORK( * ), THETA( * )
+ REAL RESULT( 15 ), RWORK( * ), THETA( * )
COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
@@ -238,15 +263,19 @@
EXTERNAL SLAMCH, CLANGE, CLANHE
* ..
* .. External Subroutines ..
- EXTERNAL CGEMM, CLACPY, CLASET, CUNCSD, CHERK
+ EXTERNAL CGEMM, CHERK, CLACPY, CLASET, CUNCSD,
+ $ CUNCSD2BY1
* ..
* .. Intrinsic Functions ..
- INTRINSIC REAL, MAX, MIN
+ INTRINSIC CMPLX, COS, MAX, MIN, REAL, SIN
* ..
* .. Executable Statements ..
*
ULP = SLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL CLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL CHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE,
$ X, LDX, REALONE, WORK, LDX )
@@ -269,86 +298,88 @@
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, RWORK, 17*(R+2), IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL CLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)),
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)),
$ 0.0E0 )
END DO
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ CMPLX( SIN(THETA(R-I+1)), 0.0E0 )
END DO
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ CMPLX( SIN(THETA(R-I+1)), 0.0E0 )
END DO
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ CMPLX( COS(THETA(I)), 0.0E0 )
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = CLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = CLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = CLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = CLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = CLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = CLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = CLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = CLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
@@ -397,14 +428,126 @@
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL CLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL CHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE,
+ $ X, LDX, REALONE, WORK, LDX )
+ IF (M.GT.0) THEN
+ EPS2 = MAX( ULP,
+ $ CLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix X to the array XF.
+*
+ CALL CLACPY( 'Full', M, Q, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL CUNCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, RWORK, 17*(R+2), IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL CGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)),
+ $ 0.0E0 )
+ END DO
+*
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ CMPLX( SIN(THETA(R-I+1)), 0.0E0 )
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = CLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = CLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL CLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL CHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE,
+ $ U1, LDU1, REALONE, WORK, LDU1 )
+*
+* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = CLANHE( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL CLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL CHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE,
+ $ U2, LDU2, REALONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = CLANHE( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL CLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL CHERK( 'Upper', 'No transpose', Q, Q, -REALONE,
+ $ V1T, LDV1T, REALONE, WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = CLANHE( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
IF( I.GT.1) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
@@ -414,4 +557,3 @@
* End of CCSDTS
*
END
-
diff --git a/lapack-netlib/TESTING/EIG/dchkee.f b/lapack-netlib/TESTING/EIG/dchkee.f
index 86cf7ba87..bde28f234 100644
--- a/lapack-netlib/TESTING/EIG/dchkee.f
+++ b/lapack-netlib/TESTING/EIG/dchkee.f
@@ -1032,17 +1032,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup double_eig
*
* =====================================================================
PROGRAM DCHKEE
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* =====================================================================
*
@@ -1133,6 +1133,10 @@
* ..
* .. Executable Statements ..
*
+ A = 0.0
+ B = 0.0
+ C = 0.0
+ D = 0.0
S1 = DSECND( )
FATAL = .FALSE.
NUNIT = NOUT
diff --git a/lapack-netlib/TESTING/EIG/dckcsd.f b/lapack-netlib/TESTING/EIG/dckcsd.f
index 94892b793..219ebafcf 100644
--- a/lapack-netlib/TESTING/EIG/dckcsd.f
+++ b/lapack-netlib/TESTING/EIG/dckcsd.f
@@ -205,13 +205,14 @@
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, TEN
- PARAMETER ( GAPDIGIT = 18.0D0, ORTH = 1.0D-12,
+ PARAMETER ( NTYPES = 4 )
+ DOUBLE PRECISION GAPDIGIT, ONE, ORTH, PIOVER2, TEN, ZERO
+ PARAMETER ( GAPDIGIT = 18.0D0, ONE = 1.0D0,
+ $ ORTH = 1.0D-12,
$ PIOVER2 = 1.57079632679489662D0,
- $ TEN = 10.0D0 )
+ $ TEN = 10.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
@@ -231,8 +232,8 @@
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- DOUBLE PRECISION DLARND
- EXTERNAL DLARND
+ DOUBLE PRECISION DLARAN, DLARND
+ EXTERNAL DLARAN, DLARND
* ..
* .. Executable Statements ..
*
@@ -286,7 +287,7 @@
$ ORTH*DLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-DLARND(1,ISEED)*GAPDIGIT)
@@ -298,9 +299,18 @@
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL DLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL DLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( DLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL DROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), 1,
+ $ ZERO, ONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
diff --git a/lapack-netlib/TESTING/EIG/dcsdts.f b/lapack-netlib/TESTING/EIG/dcsdts.f
index de0e3a93a..528092a1d 100644
--- a/lapack-netlib/TESTING/EIG/dcsdts.f
+++ b/lapack-netlib/TESTING/EIG/dcsdts.f
@@ -17,7 +17,7 @@
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+* DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
* DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
@@ -43,10 +43,25 @@
*> [ I 0 0 | 0 0 0 ]
*> [ 0 C 0 | 0 -S 0 ]
*> [ 0 0 0 | 0 0 -I ]
-*> = [---------------------] = [ D11 D12 ] .
+*> = [---------------------] = [ D11 D12 ] ,
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also DORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
@@ -171,8 +186,9 @@
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is DOUBLE PRECISION array, dimension (9)
+*> RESULT is DOUBLE PRECISION array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
@@ -184,6 +200,15 @@
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
@@ -214,7 +239,7 @@
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+ DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
@@ -238,15 +263,19 @@
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
- EXTERNAL DGEMM, DLACPY, DLASET, DORCSD, DSYRK
+ EXTERNAL DGEMM, DLACPY, DLASET, DORCSD, DORCSD2BY1,
+ $ DSYRK
* ..
* .. Intrinsic Functions ..
- INTRINSIC DBLE, MAX, MIN
+ INTRINSIC COS, DBLE, MAX, MIN, SIN
* ..
* .. Executable Statements ..
*
ULP = DLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL DSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX,
$ ONE, WORK, LDX )
@@ -269,85 +298,87 @@
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL DLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
END DO
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ SIN(THETA(R-I+1))
END DO
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ SIN(THETA(R-I+1))
END DO
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ COS(THETA(I))
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = DLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = DLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = DLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = DLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / DBLE(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = DLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = DLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = DLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = DLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / DBLE(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
@@ -396,14 +427,125 @@
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1 ) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL DSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX,
+ $ ONE, WORK, LDX )
+ IF( M.GT.0 ) THEN
+ EPS2 = MAX( ULP,
+ $ DLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix [ X11; X21 ] to the array XF.
+*
+ CALL DLACPY( 'Full', M, Q, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL DORCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ END DO
+*
+ CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ SIN(THETA(R-I+1))
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = DLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = DLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL DSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1,
+ $ ONE, WORK, LDU1 )
+*
+* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / DBLE(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL DLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL DSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2,
+ $ LDU2, ONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / DBLE(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL DSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE,
+ $ WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / DBLE(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
- IF( I.GT.1) THEN
+ IF( I.GT.1 ) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
diff --git a/lapack-netlib/TESTING/EIG/dlahd2.f b/lapack-netlib/TESTING/EIG/dlahd2.f
index 2f1cc068a..530c5d66e 100644
--- a/lapack-netlib/TESTING/EIG/dlahd2.f
+++ b/lapack-netlib/TESTING/EIG/dlahd2.f
@@ -58,17 +58,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup double_eig
*
* =====================================================================
SUBROUTINE DLAHD2( IOUNIT, PATH )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -501,8 +501,8 @@
$ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
$ / ' 3: norm( I - PT PT'' ) / ( n ulp )',
$ / ' 4: norm( Y - Q'' C ) / ( norm(Y) max(m,nrhs) ulp )' )
- 9968 FORMAT( / ' Tests performed: See sdrvst.f' )
- 9967 FORMAT( / ' Tests performed: See cdrvst.f' )
+ 9968 FORMAT( / ' Tests performed: See ddrvst.f' )
+ 9967 FORMAT( / ' Tests performed: See sdrvst.f' )
*
* End of DLAHD2
*
diff --git a/lapack-netlib/TESTING/EIG/schkee.f b/lapack-netlib/TESTING/EIG/schkee.f
index 78268622c..946b73cb0 100644
--- a/lapack-netlib/TESTING/EIG/schkee.f
+++ b/lapack-netlib/TESTING/EIG/schkee.f
@@ -1032,17 +1032,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup single_eig
*
* =====================================================================
PROGRAM SCHKEE
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* =====================================================================
*
@@ -1133,6 +1133,10 @@
* ..
* .. Executable Statements ..
*
+ A = 0.0
+ B = 0.0
+ C = 0.0
+ D = 0.0
S1 = SECOND( )
FATAL = .FALSE.
NUNIT = NOUT
diff --git a/lapack-netlib/TESTING/EIG/sckcsd.f b/lapack-netlib/TESTING/EIG/sckcsd.f
index fe5de85a7..20ba3d66f 100644
--- a/lapack-netlib/TESTING/EIG/sckcsd.f
+++ b/lapack-netlib/TESTING/EIG/sckcsd.f
@@ -205,13 +205,14 @@
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- REAL GAPDIGIT, ORTH, PIOVER2, TEN
- PARAMETER ( GAPDIGIT = 10.0E0, ORTH = 1.0E-4,
+ PARAMETER ( NTYPES = 4 )
+ REAL GAPDIGIT, ONE, ORTH, PIOVER2, TEN, ZERO
+ PARAMETER ( GAPDIGIT = 10.0E0, ONE = 1.0E0,
+ $ ORTH = 1.0E-4,
$ PIOVER2 = 1.57079632679489662E0,
- $ TEN = 10.0D0 )
+ $ TEN = 10.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
@@ -231,8 +232,8 @@
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- REAL SLARND
- EXTERNAL SLARND
+ REAL SLARAN, SLARND
+ EXTERNAL SLARAN, SLARND
* ..
* .. Executable Statements ..
*
@@ -286,7 +287,7 @@
$ ORTH*SLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-SLARND(1,ISEED)*GAPDIGIT)
@@ -298,9 +299,18 @@
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL SLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL SLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( SLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL SROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), 1,
+ $ ZERO, ONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
diff --git a/lapack-netlib/TESTING/EIG/scsdts.f b/lapack-netlib/TESTING/EIG/scsdts.f
index 74b32eadd..a326f356c 100644
--- a/lapack-netlib/TESTING/EIG/scsdts.f
+++ b/lapack-netlib/TESTING/EIG/scsdts.f
@@ -17,7 +17,7 @@
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* REAL RESULT( 9 ), RWORK( * ), THETA( * )
+* REAL RESULT( 15 ), RWORK( * ), THETA( * )
* REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
@@ -47,6 +47,21 @@
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also SORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
@@ -171,8 +186,9 @@
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is REAL array, dimension (9)
+*> RESULT is REAL array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
@@ -184,6 +200,15 @@
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
@@ -214,7 +239,7 @@
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- REAL RESULT( 9 ), RWORK( * ), THETA( * )
+ REAL RESULT( 15 ), RWORK( * ), THETA( * )
REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
@@ -238,15 +263,19 @@
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
- EXTERNAL SGEMM, SLACPY, SLASET, SORCSD, SSYRK
+ EXTERNAL SGEMM, SLACPY, SLASET, SORCSD, SORCSD2BY1,
+ $ SSYRK
* ..
* .. Intrinsic Functions ..
- INTRINSIC REAL, MAX, MIN
+ INTRINSIC COS, MAX, MIN, REAL, SIN
* ..
* .. Executable Statements ..
*
ULP = SLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL SSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX,
$ ONE, WORK, LDX )
@@ -269,85 +298,87 @@
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL SLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
END DO
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ SIN(THETA(R-I+1))
END DO
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ SIN(THETA(R-I+1))
END DO
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ COS(THETA(I))
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = SLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = SLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = SLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = SLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = SLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = SLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = SLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = SLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
@@ -396,14 +427,125 @@
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1 ) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL SLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL SSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX,
+ $ ONE, WORK, LDX )
+ IF (M.GT.0) THEN
+ EPS2 = MAX( ULP,
+ $ SLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix [X11;X21] to the array XF.
+*
+ CALL SLACPY( 'Full', M, Q, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL SORCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL SGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL SGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ END DO
+*
+ CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ SIN(THETA(R-I+1))
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = SLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = SLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL SLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL SSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1,
+ $ ONE, WORK, LDU1 )
+*
+* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = SLANSY( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL SLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL SSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2,
+ $ LDU2, ONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = SLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL SLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL SSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE,
+ $ WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = SLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
- IF( I.GT.1) THEN
+ IF( I.GT.1 ) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
diff --git a/lapack-netlib/TESTING/EIG/zchkee.f b/lapack-netlib/TESTING/EIG/zchkee.f
index 93ca8971e..ea58f377b 100644
--- a/lapack-netlib/TESTING/EIG/zchkee.f
+++ b/lapack-netlib/TESTING/EIG/zchkee.f
@@ -1026,17 +1026,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16_eig
*
* =====================================================================
PROGRAM ZCHKEE
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* =====================================================================
*
@@ -1129,6 +1129,10 @@
* ..
* .. Executable Statements ..
*
+ A = 0.0
+ B = 0.0
+ C = 0.0
+ DC = 0.0
S1 = DSECND( )
FATAL = .FALSE.
NUNIT = NOUT
diff --git a/lapack-netlib/TESTING/EIG/zckcsd.f b/lapack-netlib/TESTING/EIG/zckcsd.f
index 5385131ca..99ed5bd5d 100644
--- a/lapack-netlib/TESTING/EIG/zckcsd.f
+++ b/lapack-netlib/TESTING/EIG/zckcsd.f
@@ -205,13 +205,16 @@
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, TEN
+ PARAMETER ( NTYPES = 4 )
+ DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN
PARAMETER ( GAPDIGIT = 18.0D0, ORTH = 1.0D-12,
$ PIOVER2 = 1.57079632679489662D0,
+ $ REALONE = 1.0D0, REALZERO = 0.0D0,
$ TEN = 10.0D0 )
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
@@ -231,8 +234,8 @@
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- DOUBLE PRECISION DLARND
- EXTERNAL DLARND
+ DOUBLE PRECISION DLARAN, DLARND
+ EXTERNAL DLARAN, DLARND
* ..
* .. Executable Statements ..
*
@@ -286,7 +289,7 @@
$ ORTH*DLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-DLARND(1,ISEED)*GAPDIGIT)
@@ -298,9 +301,18 @@
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL ZLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL ZLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( DLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL ZDROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX),
+ $ 1, REALZERO, REALONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
diff --git a/lapack-netlib/TESTING/EIG/zcsdts.f b/lapack-netlib/TESTING/EIG/zcsdts.f
index 9d8ba2b55..c745d186b 100644
--- a/lapack-netlib/TESTING/EIG/zcsdts.f
+++ b/lapack-netlib/TESTING/EIG/zcsdts.f
@@ -17,7 +17,7 @@
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+* DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
* COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
@@ -47,6 +47,21 @@
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also SORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
@@ -171,8 +186,9 @@
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is DOUBLE PRECISION array, dimension (9)
+*> RESULT is DOUBLE PRECISION array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
@@ -184,6 +200,15 @@
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
@@ -214,7 +239,7 @@
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+ DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
@@ -238,15 +263,19 @@
EXTERNAL DLAMCH, ZLANGE, ZLANHE
* ..
* .. External Subroutines ..
- EXTERNAL ZGEMM, ZLACPY, ZLASET, ZUNCSD, ZHERK
+ EXTERNAL ZGEMM, ZHERK, ZLACPY, ZLASET, ZUNCSD,
+ $ ZUNCSD2BY1
* ..
* .. Intrinsic Functions ..
- INTRINSIC REAL, MAX, MIN
+ INTRINSIC COS, DBLE, DCMPLX, MAX, MIN, REAL, SIN
* ..
* .. Executable Statements ..
*
ULP = DLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL ZLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL ZHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE,
$ X, LDX, REALONE, WORK, LDX )
@@ -269,86 +298,88 @@
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, RWORK, 17*(R+2), IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL ZLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)),
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)),
$ 0.0D0 )
END DO
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 )
END DO
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 )
END DO
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ DCMPLX( COS(THETA(I)), 0.0D0 )
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = ZLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = ZLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = ZLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = ZLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
@@ -397,14 +428,126 @@
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL ZLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL ZHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE,
+ $ X, LDX, REALONE, WORK, LDX )
+ IF (M.GT.0) THEN
+ EPS2 = MAX( ULP,
+ $ ZLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix X to the array XF.
+*
+ CALL ZLACPY( 'Full', M, M, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL ZUNCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, RWORK, 17*(R+2), IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)),
+ $ 0.0D0 )
+ END DO
+*
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 )
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = ZLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = ZLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL ZLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL ZHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE,
+ $ U1, LDU1, REALONE, WORK, LDU1 )
+*
+* Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = ZLANHE( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL ZLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL ZHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE,
+ $ U2, LDU2, REALONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = ZLANHE( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL ZLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL ZHERK( 'Upper', 'No transpose', Q, Q, -REALONE,
+ $ V1T, LDV1T, REALONE, WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = ZLANHE( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
IF( I.GT.1) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
diff --git a/lapack-netlib/TESTING/LIN/CMakeLists.txt b/lapack-netlib/TESTING/LIN/CMakeLists.txt
index e6489c585..d7fb86254 100644
--- a/lapack-netlib/TESTING/LIN/CMakeLists.txt
+++ b/lapack-netlib/TESTING/LIN/CMakeLists.txt
@@ -10,10 +10,10 @@ set(SLINTST schkaa.f
schkeq.f schkgb.f schkge.f schkgt.f
schklq.f schkpb.f schkpo.f schkps.f schkpp.f
schkpt.f schkq3.f schkql.f schkqp.f schkqr.f schkrq.f
- schksp.f schksy.f schktb.f schktp.f schktr.f
+ schksp.f schksy.f schksy_rook.f schktb.f schktp.f schktr.f
schktz.f
sdrvgt.f sdrvls.f sdrvpb.f
- sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f
+ sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f
serrgt.f serrlq.f serrls.f
serrpo.f serrps.f serrql.f serrqp.f serrqr.f
serrrq.f serrsy.f serrtr.f serrtz.f serrvx.f
@@ -21,7 +21,7 @@ set(SLINTST schkaa.f
sgerqs.f sget01.f sget02.f
sget03.f sget04.f sget06.f sget07.f sgtt01.f sgtt02.f
sgtt05.f slaptm.f slarhs.f slatb4.f slatb5.f slattb.f slattp.f
- slattr.f slavsp.f slavsy.f slqt01.f slqt02.f
+ slattr.f slavsp.f slavsy.f slavsy_rook.f slqt01.f slqt02.f
slqt03.f spbt01.f spbt02.f spbt05.f spot01.f
spot02.f spot03.f spot05.f spst01.f sppt01.f
sppt02.f sppt03.f sppt05.f sptt01.f sptt02.f
@@ -29,7 +29,7 @@ set(SLINTST schkaa.f
sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f
sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f
srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f
- sspt01.f ssyt01.f
+ sspt01.f ssyt01.f ssyt01_rook.f
stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f
stpt02.f stpt03.f stpt05.f stpt06.f strt01.f
strt02.f strt03.f strt05.f strt06.f
@@ -44,13 +44,13 @@ endif()
set(CLINTST cchkaa.f
cchkeq.f cchkgb.f cchkge.f cchkgt.f
- cchkhe.f cchkhp.f cchklq.f cchkpb.f
+ cchkhe.f cchkhe_rook.f cchkhp.f cchklq.f cchkpb.f
cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f cchkqp.f
- cchkqr.f cchkrq.f cchksp.f cchksy.f cchktb.f
+ cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchktb.f
cchktp.f cchktr.f cchktz.f
- cdrvgt.f cdrvhe.f cdrvhp.f
+ cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhp.f
cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f
- cdrvsp.f cdrvsy.f
+ cdrvsp.f cdrvsy.f cdrvsy_rook.f
cerrgt.f cerrhe.f cerrlq.f
cerrls.f cerrps.f cerrql.f cerrqp.f
cerrqr.f cerrrq.f cerrsy.f cerrtr.f cerrtz.f
@@ -58,9 +58,9 @@ set(CLINTST cchkaa.f
cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f
cgerqs.f cget01.f cget02.f
cget03.f cget04.f cget07.f cgtt01.f cgtt02.f
- cgtt05.f chet01.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f
+ cgtt05.f chet01.f chet01_rook.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f
clatsp.f clatsy.f clattb.f clattp.f clattr.f
- clavhe.f clavhp.f clavsp.f clavsy.f clqt01.f
+ clavhe.f clavhe_rook.f clavhp.f clavsp.f clavsy.f clavsy_rook.f clqt01.f
clqt02.f clqt03.f cpbt01.f cpbt02.f cpbt05.f
cpot01.f cpot02.f cpot03.f cpot05.f cpst01.f
cppt01.f cppt02.f cppt03.f cppt05.f cptt01.f
@@ -69,7 +69,7 @@ set(CLINTST cchkaa.f
cqrt12.f cqrt13.f cqrt14.f cqrt15.f cqrt16.f
cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f
csbmv.f cspt01.f
- cspt02.f cspt03.f csyt01.f csyt02.f csyt03.f
+ cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt02.f csyt03.f
ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f
ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f
ctrt02.f ctrt03.f ctrt05.f ctrt06.f
@@ -87,10 +87,10 @@ set(DLINTST dchkaa.f
dchkeq.f dchkgb.f dchkge.f dchkgt.f
dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f
dchkpt.f dchkq3.f dchkql.f dchkqp.f dchkqr.f dchkrq.f
- dchksp.f dchksy.f dchktb.f dchktp.f dchktr.f
+ dchksp.f dchksy.f dchksy_rook.f dchktb.f dchktp.f dchktr.f
dchktz.f
ddrvgt.f ddrvls.f ddrvpb.f
- ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f
+ ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f
derrgt.f derrlq.f derrls.f
derrps.f derrql.f derrqp.f derrqr.f
derrrq.f derrsy.f derrtr.f derrtz.f derrvx.f
@@ -98,7 +98,7 @@ set(DLINTST dchkaa.f
dgerqs.f dget01.f dget02.f
dget03.f dget04.f dget06.f dget07.f dgtt01.f dgtt02.f
dgtt05.f dlaptm.f dlarhs.f dlatb4.f dlatb5.f dlattb.f dlattp.f
- dlattr.f dlavsp.f dlavsy.f dlqt01.f dlqt02.f
+ dlattr.f dlavsp.f dlavsy.f dlavsy_rook.f dlqt01.f dlqt02.f
dlqt03.f dpbt01.f dpbt02.f dpbt05.f dpot01.f
dpot02.f dpot03.f dpot05.f dpst01.f dppt01.f
dppt02.f dppt03.f dppt05.f dptt01.f dptt02.f
@@ -106,7 +106,7 @@ set(DLINTST dchkaa.f
dqrt01.f dqrt01p.f dqrt02.f dqrt03.f dqrt11.f dqrt12.f
dqrt13.f dqrt14.f dqrt15.f dqrt16.f dqrt17.f
drqt01.f drqt02.f drqt03.f drzt01.f drzt02.f
- dspt01.f dsyt01.f
+ dspt01.f dsyt01.f dsyt01_rook.f
dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f
dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f
dtrt02.f dtrt03.f dtrt05.f dtrt06.f
@@ -123,13 +123,13 @@ endif()
set(ZLINTST zchkaa.f
zchkeq.f zchkgb.f zchkge.f zchkgt.f
- zchkhe.f zchkhp.f zchklq.f zchkpb.f
+ zchkhe.f zchkhe_rook.f zchkhp.f zchklq.f zchkpb.f
zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f zchkqp.f
- zchkqr.f zchkrq.f zchksp.f zchksy.f zchktb.f
+ zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchktb.f
zchktp.f zchktr.f zchktz.f
- zdrvgt.f zdrvhe.f zdrvhp.f
+ zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhp.f
zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f
- zdrvsp.f zdrvsy.f
+ zdrvsp.f zdrvsy.f zdrvsy_rook.f
zerrgt.f zerrhe.f zerrlq.f
zerrls.f zerrps.f zerrql.f zerrqp.f
zerrqr.f zerrrq.f zerrsy.f zerrtr.f zerrtz.f
@@ -137,9 +137,9 @@ set(ZLINTST zchkaa.f
zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f
zgerqs.f zget01.f zget02.f
zget03.f zget04.f zget07.f zgtt01.f zgtt02.f
- zgtt05.f zhet01.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f
+ zgtt05.f zhet01.f zhet01.f zhet01_rook.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f
zlatsp.f zlatsy.f zlattb.f zlattp.f zlattr.f
- zlavhe.f zlavhp.f zlavsp.f zlavsy.f zlqt01.f
+ zlavhe.f zlavhe_rook.f zlavhp.f zlavsp.f zlavsy.f zlavsy_rook.f zlqt01.f
zlqt02.f zlqt03.f zpbt01.f zpbt02.f zpbt05.f
zpot01.f zpot02.f zpot03.f zpot05.f zpst01.f
zppt01.f zppt02.f zppt03.f zppt05.f zptt01.f
@@ -148,7 +148,7 @@ set(ZLINTST zchkaa.f
zqrt12.f zqrt13.f zqrt14.f zqrt15.f zqrt16.f
zqrt17.f zrqt01.f zrqt02.f zrqt03.f zrzt01.f zrzt02.f
zsbmv.f zspt01.f
- zspt02.f zspt03.f zsyt01.f zsyt02.f zsyt03.f
+ zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt02.f zsyt03.f
ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f
ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f
ztrt02.f ztrt03.f ztrt05.f ztrt06.f
diff --git a/lapack-netlib/TESTING/LIN/Makefile b/lapack-netlib/TESTING/LIN/Makefile
index 5b68b8f69..2352da64c 100644
--- a/lapack-netlib/TESTING/LIN/Makefile
+++ b/lapack-netlib/TESTING/LIN/Makefile
@@ -51,10 +51,10 @@ SLINTST = schkaa.o \
schkeq.o schkgb.o schkge.o schkgt.o \
schklq.o schkpb.o schkpo.o schkps.o schkpp.o \
schkpt.o schkq3.o schkql.o schkqp.o schkqr.o schkrq.o \
- schksp.o schksy.o schktb.o schktp.o schktr.o \
+ schksp.o schksy.o schksy_rook.o schktb.o schktp.o schktr.o \
schktz.o \
sdrvgt.o sdrvls.o sdrvpb.o \
- sdrvpp.o sdrvpt.o sdrvsp.o \
+ sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o\
serrgt.o serrlq.o serrls.o \
serrps.o serrql.o serrqp.o serrqr.o \
serrrq.o serrtr.o serrtz.o \
@@ -62,7 +62,7 @@ SLINTST = schkaa.o \
sgerqs.o sget01.o sget02.o \
sget03.o sget04.o sget06.o sget07.o sgtt01.o sgtt02.o \
sgtt05.o slaptm.o slarhs.o slatb4.o slatb5.o slattb.o slattp.o \
- slattr.o slavsp.o slavsy.o slqt01.o slqt02.o \
+ slattr.o slavsp.o slavsy.o slavsy_rook.o slqt01.o slqt02.o \
slqt03.o spbt01.o spbt02.o spbt05.o spot01.o \
spot02.o spot03.o spot05.o spst01.o sppt01.o \
sppt02.o sppt03.o sppt05.o sptt01.o sptt02.o \
@@ -70,7 +70,7 @@ SLINTST = schkaa.o \
sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \
sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \
srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \
- sspt01.o ssyt01.o \
+ sspt01.o ssyt01.o ssyt01_rook.o \
stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \
stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \
strt02.o strt03.o strt05.o strt06.o \
@@ -78,30 +78,30 @@ SLINTST = schkaa.o \
ifdef USEXBLAS
SLINTST += serrvxx.o sdrvgex.o sdrvsyx.o serrgex.o sdrvgbx.o sdrvpox.o \
- sebchvxx.o serrsyx.o serrpox.o
+ sebchvxx.o serrsyx.o serrpox.o
else
SLINTST += serrvx.o sdrvge.o sdrvsy.o serrge.o sdrvgb.o sdrvpo.o \
- serrsy.o serrpo.o
+ serrsy.o serrpo.o
endif
CLINTST = cchkaa.o \
cchkeq.o cchkgb.o cchkge.o cchkgt.o \
- cchkhe.o cchkhp.o cchklq.o cchkpb.o \
+ cchkhe.o cchkhe_rook.o cchkhp.o cchklq.o cchkpb.o \
cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o cchkqp.o \
- cchkqr.o cchkrq.o cchksp.o cchksy.o cchktb.o \
+ cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \
cchktp.o cchktr.o cchktz.o \
- cdrvgt.o cdrvhp.o \
+ cdrvgt.o cdrvhe_rook.o cdrvhp.o \
cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \
- cdrvsp.o \
+ cdrvsp.o cdrvsy_rook.o \
cerrgt.o cerrlq.o \
cerrls.o cerrps.o cerrql.o cerrqp.o \
cerrqr.o cerrrq.o cerrtr.o cerrtz.o \
cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \
cgerqs.o cget01.o cget02.o \
cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \
- cgtt05.o chet01.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \
+ cgtt05.o chet01.o chet01_rook.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \
clatsp.o clatsy.o clattb.o clattp.o clattr.o \
- clavhe.o clavhp.o clavsp.o clavsy.o clqt01.o \
+ clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \
clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \
cpot01.o cpot02.o cpot03.o cpot05.o cpst01.o \
cppt01.o cppt02.o cppt03.o cppt05.o cptt01.o \
@@ -110,7 +110,7 @@ CLINTST = cchkaa.o \
cqrt12.o cqrt13.o cqrt14.o cqrt15.o cqrt16.o \
cqrt17.o crqt01.o crqt02.o crqt03.o crzt01.o crzt02.o \
cspt01.o \
- cspt02.o cspt03.o csyt01.o csyt02.o csyt03.o \
+ cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt02.o csyt03.o \
ctbt02.o ctbt03.o ctbt05.o ctbt06.o ctpt01.o \
ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \
ctrt02.o ctrt03.o ctrt05.o ctrt06.o \
@@ -118,21 +118,21 @@ CLINTST = cchkaa.o \
cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o
ifdef USEXBLAS
-CLINTST += cerrvxx.o cdrvgex.o cdrvsyx.o cdrvgbx.o cerrgex.o cdrvpox.o cdrvhex.o \
- cerrpox.o cebchvxx.o cerrsyx.o cerrhex.o
+CLINTST += cerrvxx.o cdrvgex.o cdrvsyx.o cdrvgbx.o cerrgex.o cdrvpox.o \
+ cdrvhex.o cerrpox.o cebchvxx.o cerrsyx.o cerrhex.o
else
-CLINTST += cerrvx.o cdrvge.o cdrvsy.o cdrvgb.o cerrge.o cdrvpo.o cdrvhe.o \
- cerrpo.o cerrsy.o cerrhe.o
+CLINTST += cerrvx.o cdrvge.o cdrvsy.o cdrvgb.o cerrge.o cdrvpo.o \
+ cdrvhe.o cerrpo.o cerrsy.o cerrhe.o
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 dchkql.o dchkqp.o dchkqr.o dchkrq.o \
- dchksp.o dchksy.o dchktb.o dchktp.o dchktr.o \
+ dchksp.o dchksy.o dchksy_rook.o dchktb.o dchktp.o dchktr.o \
dchktz.o \
ddrvgt.o ddrvls.o ddrvpb.o \
- ddrvpp.o ddrvpt.o ddrvsp.o \
+ ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o \
derrgt.o derrlq.o derrls.o \
derrps.o derrql.o derrqp.o derrqr.o \
derrrq.o derrtr.o derrtz.o \
@@ -140,7 +140,7 @@ DLINTST = dchkaa.o \
dgerqs.o dget01.o dget02.o \
dget03.o dget04.o dget06.o dget07.o dgtt01.o dgtt02.o \
dgtt05.o dlaptm.o dlarhs.o dlatb4.o dlatb5.o dlattb.o dlattp.o \
- dlattr.o dlavsp.o dlavsy.o dlqt01.o dlqt02.o \
+ dlattr.o dlavsp.o dlavsy.o dlavsy_rook.o dlqt01.o dlqt02.o \
dlqt03.o dpbt01.o dpbt02.o dpbt05.o dpot01.o \
dpot02.o dpot03.o dpot05.o dpst01.o dppt01.o \
dppt02.o dppt03.o dppt05.o dptt01.o dptt02.o \
@@ -148,7 +148,7 @@ DLINTST = dchkaa.o \
dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \
dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \
drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \
- dspt01.o dsyt01.o \
+ dspt01.o dsyt01.o dsyt01_rook.o \
dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \
dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \
dtrt02.o dtrt03.o dtrt05.o dtrt06.o \
@@ -157,30 +157,30 @@ DLINTST = dchkaa.o \
ifdef USEXBLAS
DLINTST += derrvxx.o ddrvgex.o ddrvsyx.o ddrvgbx.o derrgex.o ddrvpox.o derrpox.o \
- debchvxx.o derrsyx.o
+ debchvxx.o derrsyx.o
else
DLINTST += derrvx.o ddrvge.o ddrvsy.o ddrvgb.o derrge.o ddrvpo.o derrpo.o \
- derrsy.o
+ derrsy.o
endif
ZLINTST = zchkaa.o \
zchkeq.o zchkgb.o zchkge.o zchkgt.o \
- zchkhe.o zchkhp.o zchklq.o zchkpb.o \
+ zchkhe.o zchkhe_rook.o zchkhp.o zchklq.o zchkpb.o \
zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o zchkqp.o \
- zchkqr.o zchkrq.o zchksp.o zchksy.o zchktb.o \
+ zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \
zchktp.o zchktr.o zchktz.o \
- zdrvgt.o zdrvhp.o \
+ zdrvgt.o zdrvhe_rook.o zdrvhp.o \
zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \
- zdrvsp.o \
+ zdrvsp.o zdrvsy_rook.o \
zerrgt.o zerrlq.o \
zerrls.o zerrps.o zerrql.o zerrqp.o \
zerrqr.o zerrrq.o zerrtr.o zerrtz.o \
zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \
zgerqs.o zget01.o zget02.o \
zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \
- zgtt05.o zhet01.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \
+ zgtt05.o zhet01.o zhet01_rook.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \
zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \
- zlavhe.o zlavhp.o zlavsp.o zlavsy.o zlqt01.o \
+ zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \
zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \
zpot01.o zpot02.o zpot03.o zpot05.o zpst01.o \
zppt01.o zppt02.o zppt03.o zppt05.o zptt01.o \
@@ -189,7 +189,7 @@ ZLINTST = zchkaa.o \
zqrt12.o zqrt13.o zqrt14.o zqrt15.o zqrt16.o \
zqrt17.o zrqt01.o zrqt02.o zrqt03.o zrzt01.o zrzt02.o \
zspt01.o \
- zspt02.o zspt03.o zsyt01.o zsyt02.o zsyt03.o \
+ zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt02.o zsyt03.o \
ztbt02.o ztbt03.o ztbt05.o ztbt06.o ztpt01.o \
ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \
ztrt02.o ztrt03.o ztrt05.o ztrt06.o \
@@ -198,10 +198,10 @@ ZLINTST = zchkaa.o \
ifdef USEXBLAS
ZLINTST += zerrvxx.o zdrvgex.o zdrvsyx.o zdrvgbx.o zerrgex.o zdrvpox.o zdrvhex.o \
- zerrpox.o zebchvxx.o zerrsyx.o zerrhex.o
+ zerrpox.o zebchvxx.o zerrsyx.o zerrhex.o
else
-ZLINTST += zerrvx.o zdrvge.o zdrvsy.o zdrvgb.o zerrge.o zdrvpo.o zdrvhe.o \
- zerrpo.o zerrsy.o zerrhe.o
+ZLINTST += zerrvx.o zdrvge.o zdrvsy.o zdrvgb.o zerrge.o zdrvpo.o \
+ zdrvhe.o zerrpo.o zerrsy.o zerrhe.o
endif
DSLINTST = dchkab.o \
@@ -251,39 +251,39 @@ xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(LAPACKLIB)
xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $^ \
../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstds : $(DSLINTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(DSLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstzc : $(ZCLINTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ZCLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstrfs : $(SLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(SLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstrfd : $(DLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(DLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstrfc : $(CLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(CLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
xlintstrfz : $(ZLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ZLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB)
-
+
../xlintsts: xlintsts
mv xlintsts $@
diff --git a/lapack-netlib/TESTING/LIN/aladhd.f b/lapack-netlib/TESTING/LIN/aladhd.f
index 6daae587b..b2bb2e038 100644
--- a/lapack-netlib/TESTING/LIN/aladhd.f
+++ b/lapack-netlib/TESTING/LIN/aladhd.f
@@ -2,19 +2,19 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ALADHD( IOUNIT, PATH )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER IOUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -47,10 +47,18 @@
*> _PP: Symmetric or Hermitian positive definite packed
*> _PB: Symmetric or Hermitian positive definite band
*> _PT: Symmetric or Hermitian positive definite tridiagonal
-*> _SY: Symmetric indefinite
-*> _SP: Symmetric indefinite packed
-*> _HE: (complex) Hermitian indefinite
-*> _HP: (complex) Hermitian indefinite packed
+*> _SY: Symmetric indefinite,
+*> with partial (Bunch-Kaufman) pivoting
+*> _SR: Symmetric indefinite,
+*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> _SP: Symmetric indefinite packed,
+*> with partial (Bunch-Kaufman) pivoting
+*> _HE: (complex) Hermitian indefinite,
+*> with partial (Bunch-Kaufman) pivoting
+*> _HR: (complex) Hermitian indefinite,
+*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> _HP: (complex) Hermitian indefinite packed,
+*> with partial (Bunch-Kaufman) pivoting
*> The first character must be one of S, D, C, or Z (C or Z only
*> if complex).
*> \endverbatim
@@ -58,22 +66,22 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup aux_lin
*
* =====================================================================
SUBROUTINE ALADHD( IOUNIT, PATH )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -223,7 +231,9 @@
ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN
*
* SY: Symmetric indefinite full
+* with partial (Bunch-Kaufman) pivoting algorithm
* SP: Symmetric indefinite packed
+* with partial (Bunch-Kaufman) pivoting algorithm
*
IF( LSAME( C3, 'Y' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
@@ -244,19 +254,43 @@
WRITE( IOUNIT, FMT = 9978 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN
+*
+* SR: Symmetric indefinite full,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
+*
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9983 )
+ ELSE
+ WRITE( IOUNIT, FMT = 9982 )
+ END IF
+*
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9974 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN
*
* HE: Hermitian indefinite full
+* with partial (Bunch-Kaufman) pivoting algorithm
* HP: Hermitian indefinite packed
+* with partial (Bunch-Kaufman) pivoting algorithm
*
IF( LSAME( C3, 'E' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
END IF
+*
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9983 )
+*
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9974 )1
WRITE( IOUNIT, FMT = 9980 )2
@@ -265,6 +299,22 @@
WRITE( IOUNIT, FMT = 9978 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN
+*
+* HR: Hermitian indefinite full,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
+*
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9983 )
+*
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9974 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE
*
@@ -286,10 +336,14 @@
$ ' positive definite band matrices' )
9993 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite tridiagonal' )
- 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices' )
+ 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices',
+ $ ', "rook" (bounded Bunch-Kaufman) pivoting' )
9991 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' indefinite packed matrices',
$ ', partial (Bunch-Kaufman) pivoting' )
+ 9891 FORMAT( / 1X, A3, ' drivers: ', A9,
+ $ ' indefinite packed matrices',
+ $ ', "rook" (bounded Bunch-Kaufman) pivoting' )
9990 FORMAT( / 1X, A3, ': No header available' )
*
* GE matrix types
diff --git a/lapack-netlib/TESTING/LIN/alaerh.f b/lapack-netlib/TESTING/LIN/alaerh.f
index 9a0f1c55c..2f58e85c8 100644
--- a/lapack-netlib/TESTING/LIN/alaerh.f
+++ b/lapack-netlib/TESTING/LIN/alaerh.f
@@ -139,7 +139,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup aux_lin
*
@@ -147,10 +147,10 @@
SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
$ N5, IMAT, NFAIL, NERRS, NOUT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -487,9 +487,19 @@
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
*
- ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'HE' ) ) THEN
-*
-* xHE, or xSY: Symmetric or Hermitian indefinite matrices
+ ELSE IF( LSAMEN( 2, P2, 'SY' )
+ $ .OR. LSAMEN( 2, P2, 'SR' )
+ $ .OR. LSAMEN( 2, P2, 'HE' )
+ $ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN
+*
+* xSY: symmetric indefinite matrices
+* with partial (Bunch-Kaufman) pivoting;
+* xSR: symmetric indefinite matrices
+* with rook (bounded Bunch-Kaufman) pivoting;
+* xHE: Hermitian indefinite matrices
+* with partial (Bunch-Kaufman) pivoting.
+* xHR: Hermitian indefinite matrices
+* with rook (bounded Bunch-Kaufman) pivoting;
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
diff --git a/lapack-netlib/TESTING/LIN/alahd.f b/lapack-netlib/TESTING/LIN/alahd.f
index a41d5c98a..c501ac75a 100644
--- a/lapack-netlib/TESTING/LIN/alahd.f
+++ b/lapack-netlib/TESTING/LIN/alahd.f
@@ -2,19 +2,19 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ALAHD( IOUNIT, PATH )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER IOUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -47,10 +47,18 @@
*> _PP: Symmetric or Hermitian positive definite packed
*> _PB: Symmetric or Hermitian positive definite band
*> _PT: Symmetric or Hermitian positive definite tridiagonal
-*> _SY: Symmetric indefinite
-*> _SP: Symmetric indefinite packed
-*> _HE: (complex) Hermitian indefinite
-*> _HP: (complex) Hermitian indefinite packed
+*> _SY: Symmetric indefinite,
+*> with partial (Bunch-Kaufman) pivoting
+*> _SR: Symmetric indefinite,
+*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> _SP: Symmetric indefinite packed,
+*> with partial (Bunch-Kaufman) pivoting
+*> _HE: (complex) Hermitian indefinite,
+*> with partial (Bunch-Kaufman) pivoting
+*> _HR: Symmetric indefinite,
+*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> _HP: (complex) Hermitian indefinite packed,
+*> with partial (Bunch-Kaufman) pivoting
*> _TR: Triangular
*> _TP: Triangular packed
*> _TB: Triangular band
@@ -73,22 +81,22 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup aux_lin
*
* =====================================================================
SUBROUTINE ALAHD( IOUNIT, PATH )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -268,7 +276,8 @@
*
ELSE IF( LSAMEN( 2, P2, 'SY' ) ) THEN
*
-* SY: Symmetric indefinite full
+* SY: Symmetric indefinite full,
+* with partial (Bunch-Kaufman) pivoting algorithm
*
IF( LSAME( C3, 'Y' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
@@ -292,10 +301,37 @@
WRITE( IOUNIT, FMT = 9957 )8
WRITE( IOUNIT, FMT = 9955 )9
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN
+*
+* SR: Symmetric indefinite full,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ WRITE( IOUNIT, FMT = 9892 )PATH, 'Symmetric'
+*
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9972 )
+ ELSE
+ WRITE( IOUNIT, FMT = 9971 )
+ END IF
+*
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9953 )1
+ WRITE( IOUNIT, FMT = 9961 )2
+ WRITE( IOUNIT, FMT = 9927 )3
+ WRITE( IOUNIT, FMT = 9928 )
+ WRITE( IOUNIT, FMT = 9926 )4
+ WRITE( IOUNIT, FMT = 9928 )
+ WRITE( IOUNIT, FMT = 9960 )5
+ WRITE( IOUNIT, FMT = 9959 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'SP' ) ) THEN
*
-* SP: Symmetric indefinite packed
+* SP: Symmetric indefinite packed,
+* with partial (Bunch-Kaufman) pivoting algorithm
*
IF( LSAME( C3, 'Y' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
@@ -321,19 +357,14 @@
*
ELSE IF( LSAMEN( 2, P2, 'HE' ) ) THEN
*
-* HE: Hermitian indefinite full
+* HE: Hermitian indefinite full,
+* with partial (Bunch-Kaufman) pivoting algorithm
+*
+ WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
*
- IF( LSAME( C3, 'E' ) ) THEN
- WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
- ELSE
- WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
- END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
- IF( SORD ) THEN
- WRITE( IOUNIT, FMT = 9972 )
- ELSE
- WRITE( IOUNIT, FMT = 9971 )
- END IF
+ WRITE( IOUNIT, FMT = 9972 )
+*
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9953 )1
WRITE( IOUNIT, FMT = 9961 )2
@@ -345,10 +376,33 @@
WRITE( IOUNIT, FMT = 9957 )8
WRITE( IOUNIT, FMT = 9955 )9
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN
+*
+* HR: Symmetric indefinite full,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ WRITE( IOUNIT, FMT = 9892 )PATH, 'Hermitian'
+*
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9972 )
+*
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9953 )1
+ WRITE( IOUNIT, FMT = 9961 )2
+ WRITE( IOUNIT, FMT = 9927 )3
+ WRITE( IOUNIT, FMT = 9928 )
+ WRITE( IOUNIT, FMT = 9926 )4
+ WRITE( IOUNIT, FMT = 9928 )
+ WRITE( IOUNIT, FMT = 9960 )5
+ WRITE( IOUNIT, FMT = 9959 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'HP' ) ) THEN
*
-* HP: Hermitian indefinite packed
+* HP: Hermitian indefinite packed,
+* with partial (Bunch-Kaufman) pivoting algorithm
*
IF( LSAME( C3, 'E' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
@@ -600,8 +654,14 @@
$ )
9994 FORMAT( / 1X, A3, ': ', A9, ' positive definite band matrices' )
9993 FORMAT( / 1X, A3, ': ', A9, ' positive definite tridiagonal' )
- 9992 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices' )
- 9991 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices' )
+ 9992 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices',
+ $ ', partial (Bunch-Kaufman) pivoting' )
+ 9991 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices',
+ $ ', partial (Bunch-Kaufman) pivoting' )
+ 9892 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices',
+ $ ', "rook" (bounded Bunch-Kaufman) pivoting' )
+ 9891 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices',
+ $ ', "rook" (bounded Bunch-Kaufman) pivoting' )
9990 FORMAT( / 1X, A3, ': Triangular matrices' )
9989 FORMAT( / 1X, A3, ': Triangular packed matrices' )
9988 FORMAT( / 1X, A3, ': Triangular band matrices' )
@@ -617,7 +677,6 @@
8000 FORMAT( / 1X, A3, ': QRT factorization for general matrices' )
8001 FORMAT( / 1X, A3, ': QRT factorization for ',
$ 'triangular-pentagonal matrices' )
-
*
* GE matrix types
*
@@ -718,7 +777,7 @@
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
-* SSY, SSP, CHE, CHP matrix types
+* SSY, SSR, SSP, CHE, CHR, CHP matrix types
*
9972 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Last n/2 rows and columns zero', / 4X,
@@ -731,7 +790,7 @@
$ '5. Middle row and column zero', 5X,
$ '10. Scaled near overflow' )
*
-* CSY, CSP matrix types
+* CSY, CSR, CSP matrix types
*
9971 FORMAT( 4X, '1. Diagonal', 24X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
@@ -894,12 +953,17 @@
9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1,
$ 'GELSX, 7-10: ', A1, 'GELSY, 11-14: ', A1, 'GELSS, 15-18: ',
$ A1, 'GELSD)' )
+ 9928 FORMAT( 7X, 'where ALPHA = ( 1 + SQRT( 17 ) ) / 8' )
+ 9927 FORMAT( 3X, I2, ': ABS( Largest element in L )', / 12X,
+ $ ' - ( 1 / ( 1 - ALPHA ) ) + THRESH' )
+ 9926 FORMAT( 3X, I2, ': Largest 2-Norm of 2-by-2 pivots', / 12X,
+ $ ' - ( ( 1 + ALPHA ) / ( 1 - ALPHA ) ) + THRESH' )
8011 FORMAT(3X,I2,': norm( R - Q''*A ) / ( M * norm(A) * EPS )' )
8012 FORMAT(3X,I2,': norm( I - Q''*Q ) / ( M * EPS )' )
8013 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( M * norm(C) * EPS )' )
8014 FORMAT(3X,I2,': norm( Q''*C - Q''*C ) / ( M * norm(C) * EPS )')
8015 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( M * norm(C) * EPS )' )
- 8016 FORMAT(3X,I2,': norm( C*Q'' - C*Q'' ) / ( M * norm(C) * EPS )')
+ 8016 FORMAT(3X,I2,': norm( C*Q'' - C*Q'' ) / ( M * norm(C) * EPS )')
8017 FORMAT(3X,I2,': norm( R - Q''*A ) / ( (M+N) * norm(A) * EPS )' )
8018 FORMAT(3X,I2,': norm( I - Q''*Q ) / ( (M+N) * EPS )' )
8019 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' )
@@ -907,7 +971,7 @@
$ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )')
8021 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' )
8022 FORMAT(3X,I2,
- $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )')
+ $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )')
*
RETURN
*
diff --git a/lapack-netlib/TESTING/LIN/cchkaa.f b/lapack-netlib/TESTING/LIN/cchkaa.f
index 8b5a85ed9..c2b5fad15 100644
--- a/lapack-netlib/TESTING/LIN/cchkaa.f
+++ b/lapack-netlib/TESTING/LIN/cchkaa.f
@@ -50,6 +50,7 @@
*> CPB 8 List types on next line if 0 < NTYPES < 8
*> CPT 12 List types on next line if 0 < NTYPES < 12
*> CHE 10 List types on next line if 0 < NTYPES < 10
+*> CHR 10 List types on next line if 0 < NTYPES < 10
*> CHP 10 List types on next line if 0 < NTYPES < 10
*> CSY 11 List types on next line if 0 < NTYPES < 11
*> CSR 11 List types on next line if 0 < NTYPES < 11
@@ -101,17 +102,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date September 2012
+*> \date November 2013
*
*> \ingroup complex_lin
*
* =====================================================================
PROGRAM CCHKAA
*
-* -- LAPACK test routine (version 3.4.2) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
+* November 2013
*
* =====================================================================
*
@@ -158,13 +159,14 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE,
- $ CCHKHP, CCHKLQ, CCHKPB, CCHKPO, CCHKPS, CCHKPP,
- $ CCHKPT, CCHKQ3, CCHKQL, CCHKQP, CCHKQR, CCHKRQ,
- $ CCHKSP, CCHKSY, CCHKTB, CCHKTP,
- $ CCHKTR, CCHKTZ, CDRVGB, CDRVGE, CDRVGT, CDRVHE,
- $ CDRVHP, CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT,
- $ CDRVSP, CDRVSY, ILAVER, CCHKQRT,
- $ CCHKQRTP
+ $ CCHKHE_ROOK, CCHKHP, CCHKLQ, CCHKPB, CCHKPO,
+ $ CCHKPS, CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQP,
+ $ CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK,
+ $ CCHKTB, CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE,
+ $ CDRVGT, CDRVHE, CDRVHE_ROOK, CDRVHP, CDRVLS,
+ $ CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY,
+ $ CDRVSY_ROOK, ILAVER, CCHKQRT, CCHKQRTP
+
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -615,7 +617,8 @@
*
ELSE IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
-* HE: Hermitian indefinite matrices
+* HE: Hermitian indefinite matrices,
+* with partial (Bunch-Kaufman) pivoting algorithm
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
@@ -637,10 +640,37 @@
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* HR: Hermitian indefinite matrices,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL CCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
-* HP: Hermitian indefinite packed matrices
+* HP: Hermitian indefinite packed matrices,
+* with partial (Bunch-Kaufman) pivoting algorithm
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
@@ -688,6 +718,32 @@
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* SR: symmetric indefinite matrices,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ NTYPES = 11
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL CCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL CDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/cchkhe.f b/lapack-netlib/TESTING/LIN/cchkhe.f
index f52f320a0..72dd71f66 100644
--- a/lapack-netlib/TESTING/LIN/cchkhe.f
+++ b/lapack-netlib/TESTING/LIN/cchkhe.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE CCHKHE( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
* XACT, WORK, RWORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NNB, NNS, NOUT
@@ -24,7 +24,7 @@
* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -135,14 +135,12 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX array, dimension
-*> (NMAX*max(3,NSMAX))
+*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
-*> RWORK is REAL array, dimension
-*> (max(NMAX,2*NSMAX))
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
*> \endverbatim
*>
*> \param[out] IWORK
@@ -159,12 +157,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -173,10 +171,10 @@
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -196,6 +194,8 @@
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
INTEGER NTYPES
PARAMETER ( NTYPES = 10 )
INTEGER NTESTS
@@ -221,7 +221,7 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, CERRHE, CGET04, CHECON,
- $ CHERFS, CHET01, CHETRF, CHETRI2, CHETRS,
+ $ CHERFS, CHET01, CHETRF, CHETRI2, CHETRS,
$ CLACPY, CLAIPD, CLARHS, CLATB4, CLATMS, CPOT02,
$ CPOT03, CPOT05, XLAENV
* ..
@@ -260,6 +260,11 @@
$ CALL CERRHE( PATH, NOUT )
INFOT = 0
*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
@@ -271,6 +276,9 @@
$ NIMAT = 1
*
IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
DO 170 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
@@ -289,27 +297,36 @@
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
-* Set up parameters with CLATB4 and generate a test matrix
-* with CLATMS.
+* Begin generate test matrix A.
+*
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
*
CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
*
SRNAMT = 'CLATMS'
CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
-* Check error code from CLATMS.
+* Check error code from CLATMS and handle error.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
GO TO 160
END IF
*
-* For types 3-6, zero one or more rows and columns of
-* the matrix to test that INFO is returned correctly.
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
@@ -327,34 +344,34 @@
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDA
DO 20 I = 1, IZERO - 1
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
- A( IOFF ) = ZERO
+ A( IOFF ) = CZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
- A( IOFF ) = ZERO
+ A( IOFF ) = CZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
50 CONTINUE
END IF
ELSE
- IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
+ IOFF = 0
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
60 CONTINUE
IOFF = IOFF + LDA
70 CONTINUE
@@ -362,10 +379,11 @@
*
* Set the last IZERO rows and columns to zero.
*
+ IOFF = 0
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
80 CONTINUE
IOFF = IOFF + LDA
90 CONTINUE
@@ -379,16 +397,30 @@
*
CALL CLAIPD( N, A, LDA+1, 0 )
*
+* End generate test matrix A.
+*
+*
* Do for each value of NB in NBVAL
*
DO 150 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
-* Compute the L*D*L' or U*D*U' factorization of the
-* matrix.
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
*
CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
LWORK = MAX( 2, NB )*LDA
SRNAMT = 'CHETRF'
CALL CHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
@@ -411,11 +443,14 @@
END IF
END IF
*
-* Check error code from CHETRF.
+* Check error code from CHETRF and handle error.
*
IF( INFO.NE.K )
$ CALL ALAERH( PATH, 'CHETRF', INFO, K, UPLO, N, N,
$ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
IF( INFO.NE.0 ) THEN
TRFCON = .TRUE.
ELSE
@@ -430,7 +465,10 @@
NT = 1
*
*+ TEST 2
-* Form the inverse and compute the residual.
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
*
IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
@@ -439,12 +477,15 @@
CALL CHETRI2( UPLO, N, AINV, LDA, IWORK, WORK,
$ LWORK, INFO )
*
-* Check error code from CHETRI.
+* Check error code from CHETRI2 and handle error.
*
IF( INFO.NE.0 )
- $ CALL ALAERH( PATH, 'CHETRI', INFO, -1, UPLO, N,
+ $ CALL ALAERH( PATH, 'CHETRI2', INFO, -1, UPLO, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
*
CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDC, RESULT( 2 ) )
@@ -477,12 +518,17 @@
RCONDC = ZERO
GO TO 140
END IF
+*
+* Do for each value of NRHS in NSVAL.
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
-*+ TEST 3
+*+ TEST 3 (Using TRS)
* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
*
SRNAMT = 'CLARHS'
CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
@@ -494,7 +540,7 @@
CALL CHETRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, INFO )
*
-* Check error code from CHETRS.
+* Check error code from CHETRS and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CHETRS', INFO, 0, UPLO, N,
@@ -502,11 +548,17 @@
$ NERRS, NOUT )
*
CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 3 ) )
*
-*+ TEST 4
+*+ TEST 4 (Using TRS2)
* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
*
SRNAMT = 'CLARHS'
CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
@@ -518,7 +570,7 @@
CALL CHETRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, WORK, INFO )
*
-* Check error code from CHETRS2.
+* Check error code from CHETRS2 and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CHETRS2', INFO, 0, UPLO, N,
@@ -526,6 +578,9 @@
$ NERRS, NOUT )
*
CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 4 ) )
*
@@ -544,7 +599,7 @@
$ RWORK( NRHS+1 ), WORK,
$ RWORK( 2*NRHS+1 ), INFO )
*
-* Check error code from CHERFS.
+* Check error code from CHERFS and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CHERFS', INFO, 0, UPLO, N,
@@ -569,7 +624,10 @@
NFAIL = NFAIL + 1
END IF
120 CONTINUE
- NRUN = NRUN + 5
+ NRUN = NRUN + 6
+*
+* End do for each value of NRHS in NSVAL.
+*
130 CONTINUE
*
*+ TEST 9
@@ -581,11 +639,13 @@
CALL CHECON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
$ WORK, INFO )
*
-* Check error code from CHECON.
+* Check error code from CHECON and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CHECON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
*
RESULT( 9 ) = SGET06( RCOND, RCONDC )
*
diff --git a/lapack-netlib/TESTING/LIN/cchkhe_rook.f b/lapack-netlib/TESTING/LIN/cchkhe_rook.f
new file mode 100644
index 000000000..7d7ab8e98
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/cchkhe_rook.f
@@ -0,0 +1,844 @@
+*> \brief \b CCHKHE_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+* XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CCHKHE_ROOK tests CHETRF_ROOK, -TRI_ROOK, -TRS_ROOK,
+*> and -CON_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+ $ XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL ONEHALF
+ PARAMETER ( ONEHALF = 0.5E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ REAL ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN,
+ $ RCOND, RCONDC, STEMP
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 )
+ REAL RESULT( NTESTS )
+ COMPLEX CDUMMY( 1 )
+* ..
+* .. External Functions ..
+ REAL CLANGE, CLANHE, SGET06
+ EXTERNAL CLANGE, CLANHE, SGET06
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRHE, CHEEVX, CGET04,
+ $ CLACPY, CLARHS, CLATB4, CLATMS, CPOT02,
+ $ CPOT03, CHECON_ROOK, CHET01_ROOK, CHETRF_ROOK,
+ $ CHETRI_ROOK, CHETRS_ROOK, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'HR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRHE( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'CHETRF_ROOK'
+ CALL CHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CHETRF_ROOK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'CHETRF_ROOK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'CHETRI_ROOK'
+ CALL CHETRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK,
+ $ INFO )
+*
+* Check error code from CHETRI_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CHETRI_ROOK', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a Hermitian matrix times
+* its inverse.
+*
+ CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in U
+*
+ STEMP = CLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ STEMP = CLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in L
+*
+ STEMP = CLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ STEMP = CLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ CALL CHEEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-2 )*LDA+K-1 ), LDA,STEMP,
+ $ STEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, CDUMMY, 1, WORK, 16,
+ $ RWORK( 3 ), IWORK( N+1 ), IDUMMY,
+ $ INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ STEMP = LAM_MAX / LAM_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = ABS( STEMP ) - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ CALL CHEEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-1 )*LDA+K ), LDA, STEMP,
+ $ STEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, CDUMMY, 1, WORK, 16,
+ $ RWORK( 3 ), IWORK( N+1 ), IDUMMY,
+ $ INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ STEMP = LAM_MAX / LAM_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = ABS( STEMP ) - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+* Begin loop over NRHS values
+*
+*
+*+ TEST 5 ( Using TRS_ROOK)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'CHETRS_ROOK'
+ CALL CHETRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from CHETRS_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CHETRS_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'CHECON_ROOK'
+ CALL CHECON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from CHECON_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CHECON_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = SGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of CCHKHE_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/cchksy.f b/lapack-netlib/TESTING/LIN/cchksy.f
index 02be26a29..d25417f7a 100644
--- a/lapack-netlib/TESTING/LIN/cchksy.f
+++ b/lapack-netlib/TESTING/LIN/cchksy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE CCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
* XACT, WORK, RWORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NNB, NNS, NOUT
@@ -24,7 +24,7 @@
* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -135,14 +135,12 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX array, dimension
-*> (NMAX*max(2,NSMAX))
+*> WORK is COMPLEX array, dimension (NMAX*max(2,NSMAX))
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
-*> RWORK is REAL array,
-*> dimension (NMAX+2*NSMAX)
+*> RWORK is REAL array, dimension (NMAX+2*NSMAX)
*> \endverbatim
*>
*> \param[out] IWORK
@@ -159,12 +157,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -173,10 +171,10 @@
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -197,7 +195,7 @@
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
COMPLEX CZERO
- PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
INTEGER NTYPES
PARAMETER ( NTYPES = 11 )
INTEGER NTESTS
@@ -299,9 +297,9 @@
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
- IF( IMAT.NE.NTYPES ) THEN
+* Begin generate test matrix A.
*
-* Begin generate the test matrix A.
+ IF( IMAT.NE.NTYPES ) THEN
*
* Set up parameters with CLATB4 for the matrix generator
* based on the type of matrix to be generated.
@@ -321,6 +319,9 @@
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
GO TO 160
END IF
*
@@ -392,18 +393,20 @@
ELSE
IZERO = 0
END IF
-*
-* End generate the test matrix A.
*
ELSE
*
-* Use a special block diagonal matrix to test alternate
-* code for the 2 x 2 blocks.
+* For matrix kind IMAT = 11, generate special block
+* diagonal matrix to test alternate code
+* for the 2 x 2 blocks.
*
CALL CLATSY( UPLO, N, A, LDA, ISEED )
*
END IF
*
+* End generate test matrix A.
+*
+*
* Do for each value of NB in NBVAL
*
DO 150 INB = 1, NNB
@@ -522,6 +525,8 @@
RCONDC = ZERO
GO TO 140
END IF
+*
+* Do for each value of NRHS in NSVAL.
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
@@ -601,7 +606,7 @@
$ RWORK( NRHS+1 ), WORK,
$ RWORK( 2*NRHS+1 ), INFO )
*
-* Check error code from CSYRFS.
+* Check error code from CSYRFS and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CSYRFS', INFO, 0, UPLO, N,
@@ -627,6 +632,9 @@
END IF
120 CONTINUE
NRUN = NRUN + 6
+*
+* End do for each value of NRHS in NSVAL.
+*
130 CONTINUE
*
*+ TEST 9
@@ -644,7 +652,7 @@
$ CALL ALAERH( PATH, 'CSYCON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
-* Compute the test ratio to compare to values of RCOND
+* Compute the test ratio to compare values of RCOND
*
RESULT( 9 ) = SGET06( RCOND, RCONDC )
*
diff --git a/lapack-netlib/TESTING/LIN/cchksy_rook.f b/lapack-netlib/TESTING/LIN/cchksy_rook.f
new file mode 100644
index 000000000..cafd4d936
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/cchksy_rook.f
@@ -0,0 +1,860 @@
+*> \brief \b CCHKSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+* XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CCHKSY_ROOK tests CSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK,
+*> and -CON_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+ $ XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL ONEHALF
+ PARAMETER ( ONEHALF = 0.5E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 11 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ REAL ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN,
+ $ RCOND, RCONDC, STEMP
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+ COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
+* ..
+* .. External Functions ..
+ REAL CLANGE, CLANSY, SGET06
+ EXTERNAL CLANGE, CLANSY, SGET06
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGEEVX, CGET04,
+ $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, CSYT02,
+ $ CSYT03, CSYCON_ROOK, CSYT01_ROOK, CSYTRF_ROOK,
+ $ CSYTRI_ROOK, CSYTRS_ROOK, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate test matrix A.
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+ ELSE
+*
+* For matrix kind IMAT = 11, generate special block
+* diagonal matrix to test alternate code
+* for the 2 x 2 blocks.
+*
+ CALL CLATSY( UPLO, N, A, LDA, ISEED )
+*
+ END IF
+*
+* End generate test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'CSYTRF_ROOK'
+ CALL CSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CSYTRF_ROOK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'CSYTRF_ROOK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'CSYTRI_ROOK'
+ CALL CSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK,
+ $ INFO )
+*
+* Check error code from CSYTRI_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CSYTRI_ROOK', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL CSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ STEMP = CLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ STEMP = CLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ STEMP = CLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ STEMP = CLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 2, 1 ) = AFAC( ( K-2 )*LDA+K )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL CGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK,
+ $ 2, WORK, CDUMMY, 1, CDUMMY, 1,
+ $ ITEMP, ITEMP2, RWORK, STEMP,
+ $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ),
+ $ 4, RWORK( 7 ), INFO )
+*
+ LAM_MAX = MAX( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+*
+ STEMP = LAM_MAX / LAM_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = ABS( STEMP ) - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = AFAC( ( K-1 )*LDA+K+1 )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL CGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK,
+ $ 2, WORK, CDUMMY, 1, CDUMMY, 1,
+ $ ITEMP, ITEMP2, RWORK, STEMP,
+ $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ),
+ $ 4, RWORK( 7 ), INFO )
+*
+ LAM_MAX = MAX( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+*
+ STEMP = LAM_MAX / LAM_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = ABS( STEMP ) - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_ROOK)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'CSYTRS_ROOK'
+ CALL CSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from CSYTRS_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CSYTRS_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'CSYCON_ROOK'
+ CALL CSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from CSYCON_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CSYCON_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = SGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of CCHKSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/cdrvhe.f b/lapack-netlib/TESTING/LIN/cdrvhe.f
index 8bf5351e4..9d5beb843 100644
--- a/lapack-netlib/TESTING/LIN/cdrvhe.f
+++ b/lapack-netlib/TESTING/LIN/cdrvhe.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE CDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
* NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NOUT, NRHS
@@ -24,7 +24,7 @@
* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -117,8 +117,7 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX array, dimension
-*> (NMAX*max(2,NRHS))
+*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
*> \endverbatim
*>
*> \param[out] RWORK
@@ -140,12 +139,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -154,10 +153,10 @@
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -226,7 +225,7 @@
*
* Initialize constants and the random number seed.
*
- PATH( 1: 1 ) = 'C'
+ PATH( 1: 1 ) = 'Complex precision'
PATH( 2: 3 ) = 'HE'
NRUN = 0
NFAIL = 0
diff --git a/lapack-netlib/TESTING/LIN/cdrvhe_rook.f b/lapack-netlib/TESTING/LIN/cdrvhe_rook.f
new file mode 100644
index 000000000..6110aadf9
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/cdrvhe_rook.f
@@ -0,0 +1,527 @@
+*> \brief \b CDRVHE_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
+* IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CDRVHE_ROOK tests the driver routines CHESV_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ REAL AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ REAL CLANHE
+ EXTERNAL CLANHE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX,
+ $ CGET04, CLACPY, CLARHS, CLATB4, CLATMS,
+ $ CHESV_ROOK, CHET01_ROOK, CPOT02,
+ $ CHETRF_ROOK, CHETRI_ROOK
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'HR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number for comparison with
+* the value returned by CHESVX_ROOK.
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+ CALL CHETRI_ROOK( UPLO, N, AINV, LDA, IWORK,
+ $ WORK, INFO )
+ AINVNM = CLANHE( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test CHESV_ROOK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* CHESV_ROOK.
+*
+ SRNAMT = 'CHESV_ROOK'
+ CALL CHESV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CHESV_ROOK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'CHESV_ROOK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'CHESV_ROOK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of CDRVHE_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/cdrvpox.f b/lapack-netlib/TESTING/LIN/cdrvpox.f
index 2f14d94ba..b763d6d9b 100644
--- a/lapack-netlib/TESTING/LIN/cdrvpox.f
+++ b/lapack-netlib/TESTING/LIN/cdrvpox.f
@@ -153,7 +153,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -162,10 +162,10 @@
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -530,11 +530,12 @@
*
* Check the error code from CPOSVX.
*
- IF( INFO.NE.IZERO )
- $ CALL ALAERH( PATH, 'CPOSVX', INFO, IZERO,
+ IF( INFO.NE.IZERO ) THEN
+ CALL ALAERH( PATH, 'CPOSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
+ END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
diff --git a/lapack-netlib/TESTING/LIN/cdrvrfp.f b/lapack-netlib/TESTING/LIN/cdrvrfp.f
index 5aa736b56..075242677 100644
--- a/lapack-netlib/TESTING/LIN/cdrvrfp.f
+++ b/lapack-netlib/TESTING/LIN/cdrvrfp.f
@@ -232,7 +232,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -244,10 +244,10 @@
+ C_WORK_CPOT03, S_WORK_CLATMS, S_WORK_CLANHE,
+ S_WORK_CPOT01, S_WORK_CPOT02, S_WORK_CPOT03 )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER NN, NNS, NNT, NOUT
@@ -345,7 +345,7 @@
*
* If N.EQ.0, only consider the first type
*
- IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120
+ IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
@@ -452,13 +452,16 @@
*
* Compute the 1-norm condition number of A.
*
- AINVNM = CLANHE( '1', UPLO, N, A, LDA,
+ IF ( N .NE. 0 ) THEN
+ AINVNM = CLANHE( '1', UPLO, N, A, LDA,
+ S_WORK_CLANHE )
- RCONDC = ( ONE / ANORM ) / AINVNM
+ RCONDC = ( ONE / ANORM ) / AINVNM
*
-* Restore the matrix A.
+* Restore the matrix A.
*
CALL CLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
+ END IF
+
*
END IF
*
diff --git a/lapack-netlib/TESTING/LIN/cdrvsy.f b/lapack-netlib/TESTING/LIN/cdrvsy.f
index e860b740d..475e90200 100644
--- a/lapack-netlib/TESTING/LIN/cdrvsy.f
+++ b/lapack-netlib/TESTING/LIN/cdrvsy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE CDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
* NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NOUT, NRHS
@@ -24,7 +24,7 @@
* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -117,8 +117,7 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX array, dimension
-*> (NMAX*max(2,NRHS))
+*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
*> \endverbatim
*>
*> \param[out] RWORK
@@ -140,12 +139,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -154,10 +153,10 @@
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
diff --git a/lapack-netlib/TESTING/LIN/cdrvsy_rook.f b/lapack-netlib/TESTING/LIN/cdrvsy_rook.f
new file mode 100644
index 000000000..4dab87576
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/cdrvsy_rook.f
@@ -0,0 +1,536 @@
+*> \brief \b CDRVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
+* IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CDRVSY_ROOK tests the driver routines CSYSV_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 11, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ REAL AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ REAL CLANSY
+ EXTERNAL CLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04,
+ $ CLACPY, CLARHS, CLASET, CLATB4, CLATMS, CLATSY,
+ $ CPOT05, CSYSV_ROOK, CSYT01_ROOK, CSYT02,
+ $ CSYTRF_ROOK, CSYTRI_ROOK
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+ ELSE
+*
+* IMAT = NTYPES: Use a special block diagonal matrix to
+* test alternate code for the 2-by-2 blocks.
+*
+ CALL CLATSY( UPLO, N, A, LDA, ISEED )
+ END IF
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number for comparison with
+* the value returned by CSYSVX_ROOK.
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+ CALL CSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK,
+ $ WORK, INFO )
+ AINVNM = CLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test CSYSV_ROOK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* CSYSV_ROOK.
+*
+ SRNAMT = 'CSYSV_ROOK'
+ CALL CSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CSYSV_ROOK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'CSYSV_ROOK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'CSYSV_ROOK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of CDRVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/cerrhe.f b/lapack-netlib/TESTING/LIN/cerrhe.f
index 03a285a1c..19a3182f7 100644
--- a/lapack-netlib/TESTING/LIN/cerrhe.f
+++ b/lapack-netlib/TESTING/LIN/cerrhe.f
@@ -2,19 +2,19 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CERRHE( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -43,22 +43,22 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -88,9 +88,10 @@
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHECON, CHERFS, CHETF2, CHETRF, CHETRI,
- $ CHETRI2, CHETRS, CHKXER, CHPCON, CHPRFS,
- $ CHPTRF, CHPTRI, CHPTRS
+ EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2,
+ $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI,
+ $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK,
+ $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -127,8 +128,9 @@
ANRM = 1.0
OK = .TRUE.
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
@@ -251,8 +253,89 @@
CALL CHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite packed matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* CHETRF_ROOK
+*
+ SRNAMT = 'CHETRF_ROOK'
+ INFOT = 1
+ CALL CHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHETF2_ROOK
+*
+ SRNAMT = 'CHETF2_ROOK'
+ INFOT = 1
+ CALL CHETF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHETRI_ROOK
+*
+ SRNAMT = 'CHETRI_ROOK'
+ INFOT = 1
+ CALL CHETRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHETRS_ROOK
+*
+ SRNAMT = 'CHETRS_ROOK'
+ INFOT = 1
+ CALL CHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHECON_ROOK
+*
+ SRNAMT = 'CHECON_ROOK'
+ INFOT = 1
+ CALL CHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/cerrhex.f b/lapack-netlib/TESTING/LIN/cerrhex.f
index cc3d2f029..6fac72787 100644
--- a/lapack-netlib/TESTING/LIN/cerrhex.f
+++ b/lapack-netlib/TESTING/LIN/cerrhex.f
@@ -51,17 +51,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -94,9 +94,11 @@
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHECON, CHERFS, CHETF2, CHETRF, CHETRI,
- $ CHETRI2, CHETRS, CHKXER, CHPCON, CHPRFS,
- $ CHPTRF, CHPTRI, CHPTRS, CHERFSX
+ EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2,
+ $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI,
+ $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK,
+ $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS,
+ $ CHERFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -134,8 +136,9 @@
ANRM = 1.0
OK = .TRUE.
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
@@ -305,8 +308,89 @@
$ PARAMS, W, R, INFO )
CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite packed matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* CHETRF_ROOK
+*
+ SRNAMT = 'CHETRF_ROOK'
+ INFOT = 1
+ CALL CHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHETF2_ROOK
+*
+ SRNAMT = 'CHETF2_ROOK'
+ INFOT = 1
+ CALL CHETF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHETRI_ROOK
+*
+ SRNAMT = 'CHETRI_ROOK'
+ INFOT = 1
+ CALL CHETRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHETRS_ROOK
+*
+ SRNAMT = 'CHETRS_ROOK'
+ INFOT = 1
+ CALL CHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CHECON_ROOK
+*
+ SRNAMT = 'CHECON_ROOK'
+ INFOT = 1
+ CALL CHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/cerrsy.f b/lapack-netlib/TESTING/LIN/cerrsy.f
index a2e82662c..f3fb81710 100644
--- a/lapack-netlib/TESTING/LIN/cerrsy.f
+++ b/lapack-netlib/TESTING/LIN/cerrsy.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -88,8 +88,9 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, CSPCON, CSPRFS, CSPTRF, CSPTRI,
- $ CSPTRS, CSYCON, CSYRFS, CSYTF2, CSYTRF, CSYTRI,
- $ CSYTRI2, CSYTRS
+ $ CSPTRS, CSYCON, CSYCON_ROOK, CSYRFS, CSYTF2,
+ $ CSYTF2_ROOK, CSYTRF, CSYTRF_ROOK, CSYTRI,
+ $ CSYTRI_ROOK, CSYTRI2, CSYTRS, CSYTRS_ROOK
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -126,11 +127,11 @@
ANRM = 1.0
OK = .TRUE.
*
- IF( LSAMEN( 2, C2, 'SY' ) ) THEN
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with patrial
-* (Bunch-Kaufman) pivoting.
+ IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* CSYTRF
*
@@ -251,11 +252,91 @@
CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* CSYTRF_ROOK
+*
+ SRNAMT = 'CSYTRF_ROOK'
+ INFOT = 1
+ CALL CSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CSYTF2_ROOK
+*
+ SRNAMT = 'CSYTF2_ROOK'
+ INFOT = 1
+ CALL CSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CSYTRI_ROOK
+*
+ SRNAMT = 'CSYTRI_ROOK'
+ INFOT = 1
+ CALL CSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CSYTRS_ROOK
+*
+ SRNAMT = 'CSYTRS_ROOK'
+ INFOT = 1
+ CALL CSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite packed matrix with patrial
-* (Bunch-Kaufman) pivoting.
+* CSYCON_ROOK
+*
+ SRNAMT = 'CSYCON_ROOK'
+ INFOT = 1
+ CALL CSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* CSPTRF
*
diff --git a/lapack-netlib/TESTING/LIN/cerrsyx.f b/lapack-netlib/TESTING/LIN/cerrsyx.f
index f904176c4..0551c1517 100644
--- a/lapack-netlib/TESTING/LIN/cerrsyx.f
+++ b/lapack-netlib/TESTING/LIN/cerrsyx.f
@@ -51,17 +51,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -95,7 +95,9 @@
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, CSPCON, CSPRFS, CSPTRF, CSPTRI,
$ CSPTRS, CSYCON, CSYRFS, CSYTF2, CSYTRF, CSYTRI,
- $ CSYTRI2, CSYTRS, CSYRFSX
+ $ CSYTRI2, CSYTRS, CSYRFSX, CSYCON_ROOK,
+ $ CSYTF2_ROOK, CSYTRF_ROOK, CSYTRI_ROOK,
+ $ CSYTRS_ROOK
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -133,8 +135,9 @@
ANRM = 1.0
OK = .TRUE.
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a symmetric indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
@@ -304,8 +307,89 @@
CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a symmetric indefinite packed matrix.
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* CSYTRF_ROOK
+*
+ SRNAMT = 'CSYTRF_ROOK'
+ INFOT = 1
+ CALL CSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CSYTF2_ROOK
+*
+ SRNAMT = 'CSYTF2_ROOK'
+ INFOT = 1
+ CALL CSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CSYTRI_ROOK
+*
+ SRNAMT = 'CSYTRI_ROOK'
+ INFOT = 1
+ CALL CSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CSYTRS_ROOK
+*
+ SRNAMT = 'CSYTRS_ROOK'
+ INFOT = 1
+ CALL CSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* CSYCON_ROOK
+*
+ SRNAMT = 'CSYCON_ROOK'
+ INFOT = 1
+ CALL CSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/cerrvx.f b/lapack-netlib/TESTING/LIN/cerrvx.f
index a91778385..52ca890d1 100644
--- a/lapack-netlib/TESTING/LIN/cerrvx.f
+++ b/lapack-netlib/TESTING/LIN/cerrvx.f
@@ -2,19 +2,19 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CERRVX( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -43,22 +43,22 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -90,10 +90,10 @@
* ..
* .. External Subroutines ..
EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX,
- $ CHESV, CHESVX, CHKXER, CHPSV, CHPSVX, CPBSV,
- $ CPBSVX, CPOSV, CPOSVX, CPPSV, CPPSVX, CPTSV,
- $ CPTSVX, CSPSV, CSPSVX, CSYSV,
- $ CSYSVX
+ $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV,
+ $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV,
+ $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV,
+ $ CSYSV_ROOK, CSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -631,6 +631,24 @@
CALL CHESVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, RW, INFO )
CALL CHKXER( 'CHESVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* CHESV_ROOK
+*
+ SRNAMT = 'CHESV_ROOK'
+ INFOT = 1
+ CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
@@ -735,6 +753,24 @@
CALL CSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, RW, INFO )
CALL CHKXER( 'CSYSVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* CSYSV_ROOK
+*
+ SRNAMT = 'CSYSV_ROOK'
+ INFOT = 1
+ CALL CSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/cerrvxx.f b/lapack-netlib/TESTING/LIN/cerrvxx.f
index 1526604a5..95b8386aa 100644
--- a/lapack-netlib/TESTING/LIN/cerrvxx.f
+++ b/lapack-netlib/TESTING/LIN/cerrvxx.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -91,10 +91,11 @@
* ..
* .. External Subroutines ..
EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX,
- $ CHESV, CHESVX, CHKXER, CHPSV, CHPSVX, CPBSV,
- $ CPBSVX, CPOSV, CPOSVX, CPPSV, CPPSVX, CPTSV,
- $ CPTSVX, CSPSV, CSPSVX, CSYSV, CSYSVX, CGESVXX,
- $ CPOSVXX, CSYSVXX, CHESVXX, CGBSVXX
+ $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV,
+ $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV,
+ $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV,
+ $ CSYSV_ROOK, CSYSVX, CGESVXX, CPOSVXX, CSYSVXX,
+ $ CHESVXX, CGBSVXX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -899,6 +900,24 @@
$ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N,
$ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO )
CALL CHKXER( 'CHESVXX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* CHESV_ROOK
+*
+ SRNAMT = 'CHESV_ROOK'
+ INFOT = 1
+ CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
@@ -1053,6 +1072,24 @@
$ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N,
$ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO )
CALL CHKXER( 'CSYSVXX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* CSYSV_ROOK
+*
+ SRNAMT = 'CSYSV_ROOK'
+ INFOT = 1
+ CALL CSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/chet01.f b/lapack-netlib/TESTING/LIN/chet01.f
index 9a1f64a74..fe08a49fd 100644
--- a/lapack-netlib/TESTING/LIN/chet01.f
+++ b/lapack-netlib/TESTING/LIN/chet01.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
* RWORK, RESID )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDAFAC, LDC, N
@@ -21,7 +21,7 @@
* REAL RWORK( * )
* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -113,12 +113,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -126,10 +126,10 @@
SUBROUTINE CHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
diff --git a/lapack-netlib/TESTING/LIN/chet01_rook.f b/lapack-netlib/TESTING/LIN/chet01_rook.f
new file mode 100644
index 000000000..1dddc7dd3
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/chet01_rook.f
@@ -0,0 +1,239 @@
+*> \brief \b CHET01_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
+* RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* REAL RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL RWORK( * )
+* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHET01_ROOK reconstructs a complex Hermitian indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix, EPS is the machine epsilon,
+*> L' is the transpose of L, and U' is the transpose of U.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> complex Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The original complex Hermitian matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (LDAFAC,N)
+*> The factored form of the matrix A. AFAC contains the block
+*> diagonal matrix D and the multipliers used to obtain the
+*> factor L or U from the block L*D*L' or U*D*U' factorization
+*> as computed by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC. LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is REAL
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ REAL RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL RWORK( * )
+ COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ COMPLEX CZERO, CONE
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
+ $ CONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ REAL ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL CLANHE, SLAMCH
+ EXTERNAL LSAME, CLANHE, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLASET, CLAVHE_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC AIMAG, REAL
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* Determine EPS and the norm of A.
+*
+ EPS = SLAMCH( 'Epsilon' )
+ ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Check the imaginary parts of the diagonal elements and return with
+* an error code if any are nonzero.
+*
+ DO 10 J = 1, N
+ IF( AIMAG( AFAC( J, J ) ).NE.ZERO ) THEN
+ RESID = ONE / EPS
+ RETURN
+ END IF
+ 10 CONTINUE
+*
+* Initialize C to the identity matrix.
+*
+ CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* Call CLAVHE_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL CLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Call CLAVHE_ROOK again to multiply by U (or L ).
+*
+ CALL CLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 30 J = 1, N
+ DO 20 I = 1, J - 1
+ C( I, J ) = C( I, J ) - A( I, J )
+ 20 CONTINUE
+ C( J, J ) = C( J, J ) - REAL( A( J, J ) )
+ 30 CONTINUE
+ ELSE
+ DO 50 J = 1, N
+ C( J, J ) = C( J, J ) - REAL( A( J, J ) )
+ DO 40 I = J + 1, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+* Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = CLANHE( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID/REAL( N ) )/ANORM ) / EPS
+ END IF
+*
+ RETURN
+*
+* End of CHET01_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/clatb4.f b/lapack-netlib/TESTING/LIN/clatb4.f
index 3b1b1dd52..f98cf24f9 100644
--- a/lapack-netlib/TESTING/LIN/clatb4.f
+++ b/lapack-netlib/TESTING/LIN/clatb4.f
@@ -61,7 +61,8 @@
*> TYPE is CHARACTER*1
*> The type of the matrix to be generated:
*> = 'S': symmetric matrix
-*> = 'P': symmetric positive (semi)definite matrix
+*> = 'H': Hermitian matrix
+*> = 'P': Hermitian positive (semi)definite matrix
*> = 'N': nonsymmetric matrix
*> \endverbatim
*>
@@ -112,7 +113,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -120,10 +121,10 @@
SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIST, TYPE
diff --git a/lapack-netlib/TESTING/LIN/clavhe.f b/lapack-netlib/TESTING/LIN/clavhe.f
index d4bd8beca..0a5016778 100644
--- a/lapack-netlib/TESTING/LIN/clavhe.f
+++ b/lapack-netlib/TESTING/LIN/clavhe.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
* LDB, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
@@ -19,118 +19,133 @@
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> CLAVHE performs one of the matrix-vector operations
-*> x := A*x or x := A^H*x,
-*> where x is an N element vector and A is one of the factors
-*> from the symmetric factorization computed by CHETRF.
-*> CHETRF produces a factorization of the form
-*> U * D * U^H or L * D * L^H,
-*> where U (or L) is a product of permutation and unit upper (lower)
-*> triangular matrices, U^H (or L^H) is the conjugate transpose of
-*> U (or L), and D is Hermitian and block diagonal with 1 x 1 and
-*> 2 x 2 diagonal blocks. The multipliers for the transformations
-*> and the upper or lower triangular parts of the diagonal blocks
-*> are stored in the leading upper or lower triangle of the 2-D
-*> array A.
+*> CLAVHE performs one of the matrix-vector operations
+*> x := A*x or x := A^H*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by CHETRF.
*>
-*> If TRANS = 'N' or 'n', CLAVHE multiplies either by U or U * D
-*> (or L or L * D).
-*> If TRANS = 'C' or 'c', CLAVHE multiplies either by U^H or D * U^H
-*> (or L^H or D * L^H ).
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
*> \endverbatim
*
* Arguments:
* ==========
*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'C': x := A^H*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
*> \verbatim
-*> UPLO - CHARACTER*1
-*> On entry, UPLO specifies whether the triangular matrix
-*> stored in A is upper or lower triangular.
-*> UPLO = 'U' or 'u' The matrix is upper triangular.
-*> UPLO = 'L' or 'l' The matrix is lower triangular.
-*> Unchanged on exit.
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
*>
-*> TRANS - CHARACTER*1
-*> On entry, TRANS specifies the operation to be performed as
-*> follows:
-*> TRANS = 'N' or 'n' x := A*x.
-*> TRANS = 'C' or 'c' x := A^H*x.
-*> Unchanged on exit.
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CHETRF_ROOK.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
*>
-*> DIAG - CHARACTER*1
-*> On entry, DIAG specifies whether the diagonal blocks are
-*> assumed to be unit matrices:
-*> DIAG = 'U' or 'u' Diagonal blocks are unit matrices.
-*> DIAG = 'N' or 'n' Diagonal blocks are non-unit.
-*> Unchanged on exit.
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
*>
-*> N - INTEGER
-*> On entry, N specifies the order of the matrix A.
-*> N must be at least zero.
-*> Unchanged on exit.
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by CHETRF.
*>
-*> NRHS - INTEGER
-*> On entry, NRHS specifies the number of right hand sides,
-*> i.e., the number of vectors x to be multiplied by A.
-*> NRHS must be at least zero.
-*> Unchanged on exit.
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
*>
-*> A - COMPLEX array, dimension( LDA, N )
-*> On entry, A contains a block diagonal matrix and the
-*> multipliers of the transformations used to obtain it,
-*> stored as a 2-D triangular matrix.
-*> Unchanged on exit.
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and
+*> columns k-1 and -IPIV(k) were interchanged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
-*> LDA - INTEGER
-*> On entry, LDA specifies the first dimension of A as declared
-*> in the calling ( sub ) program. LDA must be at least
-*> max( 1, N ).
-*> Unchanged on exit.
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
*>
-*> IPIV - INTEGER array, dimension( N )
-*> On entry, IPIV contains the vector of pivot indices as
-*> determined by CSYTRF or CHETRF.
-*> If IPIV( K ) = K, no interchange was done.
-*> If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter-
-*> changed with row IPIV( K ) and a 1 x 1 pivot block was used.
-*> If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged
-*> with row | IPIV( K ) | and a 2 x 2 pivot block was used.
-*> If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged
-*> with row | IPIV( K ) | and a 2 x 2 pivot block was used.
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and
+*> columns k+1 and -IPIV(k) were interchanged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
*>
-*> B - COMPLEX array, dimension( LDB, NRHS )
-*> On entry, B contains NRHS vectors of length N.
-*> On exit, B is overwritten with the product A * B.
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
*>
-*> LDB - INTEGER
-*> On entry, LDB contains the leading dimension of B as
-*> declared in the calling program. LDB must be at least
-*> max( 1, N ).
-*> Unchanged on exit.
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
*>
-*> INFO - INTEGER
-*> INFO is the error flag.
-*> On exit, a value of 0 indicates a successful exit.
-*> A negative value, say -K, indicates that the K-th argument
-*> has an illegal value.
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -138,10 +153,10 @@
SUBROUTINE CLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
diff --git a/lapack-netlib/TESTING/LIN/clavhe_rook.f b/lapack-netlib/TESTING/LIN/clavhe_rook.f
new file mode 100644
index 000000000..6fca41618
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/clavhe_rook.f
@@ -0,0 +1,603 @@
+*> \brief \b CLAVHE_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
+* LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIAG, TRANS, UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CLAVHE_ROOK performs one of the matrix-vector operations
+*> x := A*x or x := A^H*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by CHETRF_ROOK.
+*>
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'C': x := A^H*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CHETRF_ROOK.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by CHETRF_ROOK.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV,
+ $ B, LDB, INFO )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX CONE
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+ INTEGER J, K, KP
+ COMPLEX D11, D12, D21, D22, T1, T2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMV, CGERU, CLACGV, CSCAL, CSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, CONJG, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CLAVHE_ROOK ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ NOUNIT = LSAME( DIAG, 'N' )
+*------------------------------------------
+*
+* Compute B := A * B (No transpose)
+*
+*------------------------------------------
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := U*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop forward applying the transformations.
+*
+ K = 1
+ 10 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 30
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block
+*
+* Multiply by the diagonal element if forming U * D.
+*
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformation.
+*
+ CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K + 1
+ ELSE
+*
+* 2 x 2 pivot block
+*
+* Multiply by the diagonal block if forming U * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D12 = A( K, K+1 )
+ D21 = CONJG( D12 )
+ DO 20 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 20 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformations.
+*
+ CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL CGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the first of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K + 2
+ END IF
+ GO TO 10
+ 30 CONTINUE
+*
+* Compute B := L*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
+*
+ ELSE
+*
+* Loop backward applying the transformations to B.
+*
+ K = N
+ 40 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+* Test the pivot index. If greater than zero, a 1 x 1
+* pivot was used, otherwise a 2 x 2 pivot was used.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block:
+*
+* Multiply by the diagonal element if forming L * D.
+*
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+ KP = IPIV( K )
+*
+* Apply the transformation.
+*
+ CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K - 1
+*
+ ELSE
+*
+* 2 x 2 pivot block:
+*
+* Multiply by the diagonal block if forming L * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D21 = A( K, K-1 )
+ D12 = CONJG( D21 )
+ DO 50 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 50 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+*
+* Apply the transformation.
+*
+ CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+ CALL CGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1,
+ $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+*
+* Swap the second of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+ END IF
+ K = K - 2
+ END IF
+ GO TO 40
+ 60 CONTINUE
+ END IF
+*--------------------------------------------------
+*
+* Compute B := A^H * B (conjugate transpose)
+*
+*--------------------------------------------------
+ ELSE
+*
+* Form B := U^H*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m)
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop backward applying the transformations.
+*
+ K = N
+ 70 IF( K.LT.1 )
+ $ GO TO 90
+*
+* 1 x 1 pivot block.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.GT.1 ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+* y = y - B' conjg(x),
+* where x is a column of A and y is a row of B.
+*
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate', K-1, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.GT.2 ) THEN
+*
+* Swap the second of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the first of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformations
+* y = y - B' conjg(x),
+* where x is a block column of A and y is a block
+* row of B.
+*
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+*
+ CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+ CALL CGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D12 = A( K-1, K )
+ D21 = CONJG( D12 )
+ DO 80 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 80 CONTINUE
+ END IF
+ K = K - 2
+ END IF
+ GO TO 70
+ 90 CONTINUE
+*
+* Form B := L^H*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
+* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1)
+*
+ ELSE
+*
+* Loop forward applying the L-transformations.
+*
+ K = 1
+ 100 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 120
+*
+* 1 x 1 pivot block
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.LT.N ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate', N-K, NRHS, CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.LT.N-1 ) THEN
+*
+* Swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the second of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformation
+*
+ CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+ CALL CGEMV( 'Conjugate', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE,
+ $ B( K+1, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+*
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ CALL CGEMV( 'Conjugate', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE,
+ $ B( K, 1 ), LDB )
+ CALL CLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D21 = A( K+1, K )
+ D12 = CONJG( D21 )
+ DO 110 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 110 CONTINUE
+ END IF
+ K = K + 2
+ END IF
+ GO TO 100
+ 120 CONTINUE
+ END IF
+*
+ END IF
+ RETURN
+*
+* End of CLAVHE_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/clavsy.f b/lapack-netlib/TESTING/LIN/clavsy.f
index 5dabb333c..c4d885cc0 100644
--- a/lapack-netlib/TESTING/LIN/clavsy.f
+++ b/lapack-netlib/TESTING/LIN/clavsy.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
* LDB, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
@@ -19,14 +19,14 @@
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> CLAVSY performs one of the matrix-vector operations
+*> CLAVSY performs one of the matrix-vector operations
*> x := A*x or x := A'*x,
*> where x is an N element vector and A is one of the factors
*> from the block U*D*U' or L*D*L' factorization computed by CSYTRF.
@@ -83,6 +83,7 @@
*> A is COMPLEX array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by CSYTRF.
+*> Stored as a 2-D triangular matrix.
*> \endverbatim
*>
*> \param[in] LDA
@@ -95,7 +96,7 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D,
-*> as determined by CSYTRF or CHETRF.
+*> as determined by CSYTRF.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
@@ -139,12 +140,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -152,10 +153,10 @@
SUBROUTINE CLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
diff --git a/lapack-netlib/TESTING/LIN/clavsy_rook.f b/lapack-netlib/TESTING/LIN/clavsy_rook.f
new file mode 100644
index 000000000..73f6e9acc
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/clavsy_rook.f
@@ -0,0 +1,580 @@
+*> \brief \b CLAVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
+* LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIAG, TRANS, UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CLAVSY_ROOK performs one of the matrix-vector operations
+*> x := A*x or x := A'*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by CSYTRF_ROOK.
+*>
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'T': x := A'*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by CSYTRF_ROOK.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by CSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV,
+ $ B, LDB, INFO )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX CONE
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+ INTEGER J, K, KP
+ COMPLEX D11, D12, D21, D22, T1, T2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMV, CGERU, CSCAL, CSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CLAVSY_ROOK ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ NOUNIT = LSAME( DIAG, 'N' )
+*------------------------------------------
+*
+* Compute B := A * B (No transpose)
+*
+*------------------------------------------
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := U*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop forward applying the transformations.
+*
+ K = 1
+ 10 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 30
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block
+*
+* Multiply by the diagonal element if forming U * D.
+*
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformation.
+*
+ CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K + 1
+ ELSE
+*
+* 2 x 2 pivot block
+*
+* Multiply by the diagonal block if forming U * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D12 = A( K, K+1 )
+ D21 = D12
+ DO 20 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 20 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformations.
+*
+ CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL CGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the first of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K + 2
+ END IF
+ GO TO 10
+ 30 CONTINUE
+*
+* Compute B := L*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
+*
+ ELSE
+*
+* Loop backward applying the transformations to B.
+*
+ K = N
+ 40 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+* Test the pivot index. If greater than zero, a 1 x 1
+* pivot was used, otherwise a 2 x 2 pivot was used.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block:
+*
+* Multiply by the diagonal element if forming L * D.
+*
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+ KP = IPIV( K )
+*
+* Apply the transformation.
+*
+ CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K - 1
+*
+ ELSE
+*
+* 2 x 2 pivot block:
+*
+* Multiply by the diagonal block if forming L * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D21 = A( K, K-1 )
+ D12 = D21
+ DO 50 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 50 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+*
+* Apply the transformation.
+*
+ CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+ CALL CGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1,
+ $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the second of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K - 2
+ END IF
+ GO TO 40
+ 60 CONTINUE
+ END IF
+*----------------------------------------
+*
+* Compute B := A' * B (transpose)
+*
+*----------------------------------------
+ ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+* Form B := U'*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop backward applying the transformations.
+*
+ K = N
+ 70 IF( K.LT.1 )
+ $ GO TO 90
+*
+* 1 x 1 pivot block.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.GT.1 ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL CGEMV( 'Transpose', K-1, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.GT.2 ) THEN
+*
+* Swap the second of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the first of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformations
+*
+ CALL CGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL CGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D12 = A( K-1, K )
+ D21 = D12
+ DO 80 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 80 CONTINUE
+ END IF
+ K = K - 2
+ END IF
+ GO TO 70
+ 90 CONTINUE
+*
+* Form B := L'*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
+* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
+*
+ ELSE
+*
+* Loop forward applying the L-transformations.
+*
+ K = 1
+ 100 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 120
+*
+* 1 x 1 pivot block
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.LT.N ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL CGEMV( 'Transpose', N-K, NRHS, CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.LT.N-1 ) THEN
+*
+* Swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the second of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformation
+*
+ CALL CGEMV( 'Transpose', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE,
+ $ B( K+1, 1 ), LDB )
+ CALL CGEMV( 'Transpose', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE,
+ $ B( K, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D21 = A( K+1, K )
+ D12 = D21
+ DO 110 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 110 CONTINUE
+ END IF
+ K = K + 2
+ END IF
+ GO TO 100
+ 120 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of CLAVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/csyt01.f b/lapack-netlib/TESTING/LIN/csyt01.f
index 31acf4687..ff068b2d1 100644
--- a/lapack-netlib/TESTING/LIN/csyt01.f
+++ b/lapack-netlib/TESTING/LIN/csyt01.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
* RWORK, RESID )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDAFAC, LDC, N
@@ -21,7 +21,7 @@
* REAL RWORK( * )
* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -112,12 +112,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex_lin
*
@@ -125,10 +125,10 @@
SUBROUTINE CSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
diff --git a/lapack-netlib/TESTING/LIN/csyt01_rook.f b/lapack-netlib/TESTING/LIN/csyt01_rook.f
new file mode 100644
index 000000000..cea6f5e8b
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/csyt01_rook.f
@@ -0,0 +1,227 @@
+*> \brief \b CSYT01_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
+* RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* REAL RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL RWORK( * )
+* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYT01_ROOK reconstructs a complex symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix, EPS is the machine epsilon,
+*> L' is the transpose of L, and U' is the transpose of U.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> complex symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The original complex symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (LDAFAC,N)
+*> The factored form of the matrix A. AFAC contains the block
+*> diagonal matrix D and the multipliers used to obtain the
+*> factor L or U from the block L*D*L' or U*D*U' factorization
+*> as computed by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC. LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is REAL
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ REAL RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL RWORK( * )
+ COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ COMPLEX CZERO, CONE
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
+ $ CONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ REAL ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL CLANSY, SLAMCH
+ EXTERNAL LSAME, CLANSY, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLASET, CLAVSY_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* Determine EPS and the norm of A.
+*
+ EPS = SLAMCH( 'Epsilon' )
+ ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Initialize C to the identity matrix.
+*
+ CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* Call CLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL CLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Call CLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL CLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = CLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID/REAL( N ) )/ANORM ) / EPS
+ END IF
+*
+ RETURN
+*
+* End of CSYT01_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/dchkaa.f b/lapack-netlib/TESTING/LIN/dchkaa.f
index e90897d50..e256d84f9 100644
--- a/lapack-netlib/TESTING/LIN/dchkaa.f
+++ b/lapack-netlib/TESTING/LIN/dchkaa.f
@@ -158,9 +158,9 @@
EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ,
$ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3,
$ DCHKQL, DCHKQP, DCHKQR, DCHKRQ, DCHKSP, DCHKSY,
- $ DCHKTB, DCHKTP, DCHKTR, DCHKTZ,
+ $ DCHKSY_ROOK, DCHKTB, DCHKTP, DCHKTR, DCHKTZ,
$ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO,
- $ DDRVPP, DDRVPT, DDRVSP, DDRVSY,
+ $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK,
$ ILAVER, DCHKQRT, DCHKQRTP
* ..
* .. Scalars in Common ..
@@ -637,6 +637,32 @@
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* SR: symmetric indefinite matrices with Rook pivoting,
+* with rook (bounded Bunch-Kaufman) pivoting algorithm
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/dchksy.f b/lapack-netlib/TESTING/LIN/dchksy.f
index 3295f1357..d8981f735 100644
--- a/lapack-netlib/TESTING/LIN/dchksy.f
+++ b/lapack-netlib/TESTING/LIN/dchksy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
* XACT, WORK, RWORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NNB, NNS, NOUT
@@ -23,7 +23,7 @@
* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -134,14 +134,12 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is DOUBLE PRECISION array, dimension
-*> (NMAX*max(3,NSMAX))
+*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX))
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
-*> RWORK is DOUBLE PRECISION array, dimension
-*> (max(NMAX,2*NSMAX))
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
*> \endverbatim
*>
*> \param[out] IWORK
@@ -158,12 +156,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup double_lin
*
@@ -172,10 +170,10 @@
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -220,7 +218,7 @@
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY,
$ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05,
- $ DSYCON, DSYRFS, DSYT01, DSYTRF,
+ $ DSYCON, DSYRFS, DSYT01, DSYTRF,
$ DSYTRI2, DSYTRS, DSYTRS2, XLAENV
* ..
* .. Intrinsic Functions ..
@@ -297,6 +295,7 @@
*
* Begin generate the test matrix A.
*
+*
* Set up parameters with DLATB4 for the matrix generator
* based on the type of matrix to be generated.
*
@@ -315,6 +314,9 @@
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
GO TO 160
END IF
*
@@ -357,11 +359,11 @@
50 CONTINUE
END IF
ELSE
- IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
+ IOFF = 0
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
@@ -373,6 +375,7 @@
*
* Set the last IZERO rows and columns to zero.
*
+ IOFF = 0
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
@@ -506,6 +509,8 @@
RCONDC = ZERO
GO TO 140
END IF
+*
+* Do for each value of NRHS in NSVAL.
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
@@ -586,7 +591,7 @@
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
-* Check error code from DSYRFS.
+* Check error code from DSYRFS and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSYRFS', INFO, 0, UPLO, N,
@@ -612,6 +617,9 @@
END IF
120 CONTINUE
NRUN = NRUN + 6
+*
+* End do for each value of NRHS in NSVAL.
+*
130 CONTINUE
*
*+ TEST 9
@@ -629,7 +637,7 @@
$ CALL ALAERH( PATH, 'DSYCON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
-* Compute the test ratio to compare to values of RCOND
+* Compute the test ratio to compare values of RCOND
*
RESULT( 9 ) = DGET06( RCOND, RCONDC )
*
diff --git a/lapack-netlib/TESTING/LIN/dchksy_rook.f b/lapack-netlib/TESTING/LIN/dchksy_rook.f
new file mode 100644
index 000000000..e7cea27f7
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/dchksy_rook.f
@@ -0,0 +1,830 @@
+*> \brief \b DCHKSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+* XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DCHKSY_ROOK tests DSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK,
+*> and -CON_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+ $ XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK,
+ $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN,
+ $ NT
+ DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, LAM_MAX,
+ $ LAM_MIN, RCOND, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION DDUMMY( 1 ), RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DGET06, DLANGE, DLANSY
+ EXTERNAL DGET06, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY,
+ $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DSYEVX,
+ $ DSYCON_ROOK, DSYT01_ROOK, DSYTRF_ROOK,
+ $ DSYTRI_ROOK, DSYTRS_ROOK, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Double precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL DERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with DLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with DLATMS.
+*
+ SRNAMT = 'DLATMS'
+ CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from DLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'DSYTRF_ROOK'
+ CALL DSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from DSYTRF_ROOK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'DSYTRF_ROOK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'DSYTRI_ROOK'
+ CALL DSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK,
+ $ INFO )
+*
+* Check error code from DSYTRI_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DSYTRI_ROOK', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ONE / ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ DTEMP = DLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ DTEMP = DLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ DTEMP = DLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ DTEMP = DLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ONE+ALPHA ) / ( ONE-ALPHA )
+ CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in RWORK array
+*
+ CALL DSYEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-2 )*LDA+K-1 ), LDA, DTEMP,
+ $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, DDUMMY, 1, WORK, 16,
+ $ IWORK( N+1 ), IDUMMY, INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ DTEMP = LAM_MAX / LAM_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = ABS( DTEMP ) - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in RWORK array
+*
+ CALL DSYEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-1 )*LDA+K ), LDA, DTEMP,
+ $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, DDUMMY, 1, WORK, 16,
+ $ IWORK( N+1 ), IDUMMY, INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ DTEMP = LAM_MAX / LAM_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = ABS( DTEMP ) - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_ROOK)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'DLARHS'
+ CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'DSYTRS_ROOK'
+ CALL DSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from DSYTRS_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DSYTRS_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'DSYCON_ROOK'
+ CALL DSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM,
+ $ RCOND, WORK, IWORK( N+1 ), INFO )
+*
+* Check error code from DSYCON_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DSYCON_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare to values of RCOND
+*
+ RESULT( 7 ) = DGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of DCHKSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/ddrvpox.f b/lapack-netlib/TESTING/LIN/ddrvpox.f
index 5f1370ed7..a3ab10483 100644
--- a/lapack-netlib/TESTING/LIN/ddrvpox.f
+++ b/lapack-netlib/TESTING/LIN/ddrvpox.f
@@ -158,7 +158,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup double_lin
*
@@ -167,10 +167,10 @@
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -529,11 +529,12 @@
*
* Check the error code from DPOSVX.
*
- IF( INFO.NE.IZERO )
- $ CALL ALAERH( PATH, 'DPOSVX', INFO, IZERO,
+ IF( INFO.NE.IZERO ) THEN
+ CALL ALAERH( PATH, 'DPOSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
+ END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
diff --git a/lapack-netlib/TESTING/LIN/ddrvrfp.f b/lapack-netlib/TESTING/LIN/ddrvrfp.f
index 033c033ba..5f44006b9 100644
--- a/lapack-netlib/TESTING/LIN/ddrvrfp.f
+++ b/lapack-netlib/TESTING/LIN/ddrvrfp.f
@@ -231,7 +231,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup double_lin
*
@@ -243,10 +243,10 @@
+ D_TEMP_DPOT03, D_WORK_DLANSY,
+ D_WORK_DPOT02, D_WORK_DPOT03 )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER NN, NNS, NNT, NOUT
@@ -342,7 +342,7 @@
*
* If N.EQ.0, only consider the first type
*
- IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120
+ IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
@@ -442,16 +442,20 @@
* Form the inverse of A.
*
CALL DPOTRI( UPLO, N, A, LDA, INFO )
+
+ IF ( N .NE. 0 ) THEN
+
*
-* Compute the 1-norm condition number of A.
+* Compute the 1-norm condition number of A.
*
- AINVNM = DLANSY( '1', UPLO, N, A, LDA,
+ AINVNM = DLANSY( '1', UPLO, N, A, LDA,
+ D_WORK_DLANSY )
- RCONDC = ( ONE / ANORM ) / AINVNM
+ RCONDC = ( ONE / ANORM ) / AINVNM
*
-* Restore the matrix A.
+* Restore the matrix A.
*
- CALL DLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
+ CALL DLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
+ END IF
*
END IF
*
diff --git a/lapack-netlib/TESTING/LIN/ddrvsy.f b/lapack-netlib/TESTING/LIN/ddrvsy.f
index 7978ea0cc..ec94c4710 100644
--- a/lapack-netlib/TESTING/LIN/ddrvsy.f
+++ b/lapack-netlib/TESTING/LIN/ddrvsy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE DDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
* NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NOUT, NRHS
@@ -23,7 +23,7 @@
* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -116,8 +116,7 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is DOUBLE PRECISION array, dimension
-*> (NMAX*max(2,NRHS))
+*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS))
*> \endverbatim
*>
*> \param[out] RWORK
@@ -139,12 +138,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup double_lin
*
@@ -153,10 +152,10 @@
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
diff --git a/lapack-netlib/TESTING/LIN/ddrvsy_rook.f b/lapack-netlib/TESTING/LIN/ddrvsy_rook.f
new file mode 100644
index 000000000..670fc8cff
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/ddrvsy_rook.f
@@ -0,0 +1,526 @@
+*> \brief \b DDRVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+* $ RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DDRVSY_ROOK tests the driver routines DSYSV_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLANSY
+ EXTERNAL DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY,
+ $ DLARHS, DLASET, DLATB4, DLATMS, DPOT02, DPOT05,
+ $ DSYSV_ROOK, DSYT01_ROOK, DSYTRF_ROOK,
+ $ DSYTRI_ROOK,
+ $ XLAENV
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Double precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL DERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with DLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with DLATMS.
+*
+ SRNAMT = 'DLATMS'
+ CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from DLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of the
+* matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IOFF = 0
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number for comparison with
+* the value returned by DSYSVX_ROOK.
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+ CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL DSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+ CALL DSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK,
+ $ WORK, INFO )
+ AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'DLARHS'
+ CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test DSYSV_ROOK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* DSYSV_ROOK.
+*
+ SRNAMT = 'DSYSV_ROOK'
+ CALL DSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from DSYSV_ROOK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'DSYSV_ROOK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'DSYSV_ROOK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of DDRVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/derrsy.f b/lapack-netlib/TESTING/LIN/derrsy.f
index aa60e1bbc..48a17a717 100644
--- a/lapack-netlib/TESTING/LIN/derrsy.f
+++ b/lapack-netlib/TESTING/LIN/derrsy.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -87,8 +87,9 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI,
- $ DSPTRS, DSYCON, DSYRFS, DSYTF2, DSYTRF, DSYTRI,
- $ DSYTRI2, DSYTRS
+ $ DSPTRS, DSYCON, DSYCON_ROOK, DSYRFS, DSYTF2,
+ $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI,
+ $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -251,6 +252,86 @@
INFOT = 6
CALL DSYCON( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO )
CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting.
+*
+* DSYTRF_ROOK
+*
+ SRNAMT = 'DSYTRF_ROOK'
+ INFOT = 1
+ CALL DSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYTF2_ROOK
+*
+ SRNAMT = 'DSYTF2_ROOK'
+ INFOT = 1
+ CALL DSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYTRI_ROOK
+*
+ SRNAMT = 'DSYTRI_ROOK'
+ INFOT = 1
+ CALL DSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYTRS_ROOK
+*
+ SRNAMT = 'DSYTRS_ROOK'
+ INFOT = 1
+ CALL DSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYCON_ROOK
+*
+ SRNAMT = 'DSYCON_ROOK'
+ INFOT = 1
+ CALL DSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO)
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/derrsyx.f b/lapack-netlib/TESTING/LIN/derrsyx.f
index d94c02fb8..b6d300bf0 100644
--- a/lapack-netlib/TESTING/LIN/derrsyx.f
+++ b/lapack-netlib/TESTING/LIN/derrsyx.f
@@ -51,17 +51,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -92,9 +92,11 @@
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI,
- $ DSPTRS, DSYCON, DSYRFS, DSYTF2, DSYTRF, DSYTRI,
- $ DSYTRI2, DSYTRS, DSYRFSX
+ EXTERNAL ALAESM, CHKXER, DSPCON, DSYCON_ROOK, DSPRFS,
+ $ DSPTRF, DSPTRI, DSPTRS, DSYCON, DSYRFS, DSYTF2,
+ $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI,
+ $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK,
+ $ DSYRFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -136,8 +138,9 @@
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
-* Test error exits of the routines that use the Bunch-Kaufman
-* factorization of a symmetric indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) pivoting.
*
* DSYTRF
*
@@ -304,11 +307,92 @@
INFOT = 6
CALL DSYCON( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO )
CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting.
+*
+* DSYTRF_ROOK
+*
+ SRNAMT = 'DSYTRF_ROOK'
+ INFOT = 1
+ CALL DSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYTF2_ROOK
+*
+ SRNAMT = 'DSYTF2_ROOK'
+ INFOT = 1
+ CALL DSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYTRI_ROOK
+*
+ SRNAMT = 'DSYTRI_ROOK'
+ INFOT = 1
+ CALL DSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYTRS_ROOK
+*
+ SRNAMT = 'DSYTRS_ROOK'
+ INFOT = 1
+ CALL DSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* DSYCON_ROOK
+*
+ SRNAMT = 'DSYCON_ROOK'
+ INFOT = 1
+ CALL DSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO)
+ CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
-* Test error exits of the routines that use the Bunch-Kaufman
-* factorization of a symmetric indefinite packed matrix.
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) pivoting.
*
* DSPTRF
*
diff --git a/lapack-netlib/TESTING/LIN/derrvx.f b/lapack-netlib/TESTING/LIN/derrvx.f
index b8a16bfec..ea9a7d0d5 100644
--- a/lapack-netlib/TESTING/LIN/derrvx.f
+++ b/lapack-netlib/TESTING/LIN/derrvx.f
@@ -91,7 +91,7 @@
EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV,
$ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV,
$ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV,
- $ DSYSVX
+ $ DSYSV_ROOK, DSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -626,6 +626,24 @@
CALL DSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* DSYSV_ROOK
+*
+ SRNAMT = 'DSYSV_ROOK'
+ INFOT = 1
+ CALL DSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/derrvxx.f b/lapack-netlib/TESTING/LIN/derrvxx.f
index 35dd2c804..db32956a4 100644
--- a/lapack-netlib/TESTING/LIN/derrvxx.f
+++ b/lapack-netlib/TESTING/LIN/derrvxx.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
diff --git a/lapack-netlib/TESTING/LIN/dlavsy.f b/lapack-netlib/TESTING/LIN/dlavsy.f
index e869ac0a8..b512ff0ff 100644
--- a/lapack-netlib/TESTING/LIN/dlavsy.f
+++ b/lapack-netlib/TESTING/LIN/dlavsy.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
* LDB, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
@@ -19,7 +19,7 @@
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -85,6 +85,7 @@
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by DSYTRF.
+*> Stored as a 2-D triangular matrix.
*> \endverbatim
*>
*> \param[in] LDA
@@ -141,12 +142,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup double_lin
*
@@ -154,10 +155,10 @@
SUBROUTINE DLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
diff --git a/lapack-netlib/TESTING/LIN/dlavsy_rook.f b/lapack-netlib/TESTING/LIN/dlavsy_rook.f
new file mode 100644
index 000000000..7b0c2c152
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/dlavsy_rook.f
@@ -0,0 +1,584 @@
+*> \brief \b DLAVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
+* LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIAG, TRANS, UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLAVSY_ROOK performs one of the matrix-vector operations
+*> x := A*x or x := A'*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by DSYTRF_ROOK.
+*>
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
+*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'T': x := A'*x
+*> = 'C': x := A'*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by DSYTRF_ROOK.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by DSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV,
+ $ B, LDB, INFO )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+ INTEGER J, K, KP
+ DOUBLE PRECISION D11, D12, D21, D22, T1, T2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAVSY_ROOK ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ NOUNIT = LSAME( DIAG, 'N' )
+*------------------------------------------
+*
+* Compute B := A * B (No transpose)
+*
+*------------------------------------------
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := U*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop forward applying the transformations.
+*
+ K = 1
+ 10 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 30
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block
+*
+* Multiply by the diagonal element if forming U * D.
+*
+ IF( NOUNIT )
+ $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformation.
+*
+ CALL DGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Interchange if P(K) .ne. I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K + 1
+ ELSE
+*
+* 2 x 2 pivot block
+*
+* Multiply by the diagonal block if forming U * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D12 = A( K, K+1 )
+ D21 = D12
+ DO 20 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 20 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformations.
+*
+ CALL DGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL DGER( K-1, NRHS, ONE, A( 1, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the first of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K + 2
+ END IF
+ GO TO 10
+ 30 CONTINUE
+*
+* Compute B := L*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
+*
+ ELSE
+*
+* Loop backward applying the transformations to B.
+*
+ K = N
+ 40 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+* Test the pivot index. If greater than zero, a 1 x 1
+* pivot was used, otherwise a 2 x 2 pivot was used.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block:
+*
+* Multiply by the diagonal element if forming L * D.
+*
+ IF( NOUNIT )
+ $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+ KP = IPIV( K )
+*
+* Apply the transformation.
+*
+ CALL DGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K - 1
+*
+ ELSE
+*
+* 2 x 2 pivot block:
+*
+* Multiply by the diagonal block if forming L * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D21 = A( K, K-1 )
+ D12 = D21
+ DO 50 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 50 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+*
+* Apply the transformation.
+*
+ CALL DGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+ CALL DGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1,
+ $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the second of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K - 2
+ END IF
+ GO TO 40
+ 60 CONTINUE
+ END IF
+*----------------------------------------
+*
+* Compute B := A' * B (transpose)
+*
+*----------------------------------------
+ ELSE
+*
+* Form B := U'*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop backward applying the transformations.
+*
+ K = N
+ 70 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 90
+*
+* 1 x 1 pivot block.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.GT.1 ) THEN
+*
+* Interchange if P(K) .ne. I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL DGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
+ $ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.GT.2 ) THEN
+*
+* Swap the second of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the first of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformations
+*
+ CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
+ $ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
+ $ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D12 = A( K-1, K )
+ D21 = D12
+ DO 80 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 80 CONTINUE
+ END IF
+ K = K - 2
+ END IF
+ GO TO 70
+ 90 CONTINUE
+*
+* Form B := L'*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
+* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
+*
+ ELSE
+*
+* Loop forward applying the L-transformations.
+*
+ K = 1
+ 100 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 120
+*
+* 1 x 1 pivot block
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.LT.N ) THEN
+*
+* Interchange if P(K) .ne. I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL DGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.LT.N-1 ) THEN
+*
+* Swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the second of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformation
+*
+ CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE,
+ $ B( K+1, 1 ), LDB )
+ CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE,
+ $ B( K, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D21 = A( K+1, K )
+ D12 = D21
+ DO 110 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 110 CONTINUE
+ END IF
+ K = K + 2
+ END IF
+ GO TO 100
+ 120 CONTINUE
+ END IF
+*
+ END IF
+ RETURN
+*
+* End of DLAVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/dsyt01.f b/lapack-netlib/TESTING/LIN/dsyt01.f
index 4d07aafb8..f61b9113c 100644
--- a/lapack-netlib/TESTING/LIN/dsyt01.f
+++ b/lapack-netlib/TESTING/LIN/dsyt01.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
* RWORK, RESID )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDAFAC, LDC, N
@@ -21,7 +21,7 @@
* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
* $ RWORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -111,12 +111,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup double_lin
*
@@ -124,10 +124,10 @@
SUBROUTINE DSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
diff --git a/lapack-netlib/TESTING/LIN/dsyt01_rook.f b/lapack-netlib/TESTING/LIN/dsyt01_rook.f
new file mode 100644
index 000000000..cb6668b18
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/dsyt01_rook.f
@@ -0,0 +1,223 @@
+*> \brief \b DSYT01_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
+* RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* $ RWORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYT01_ROOK reconstructs a symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> The original symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N)
+*> The factored form of the matrix A. AFAC contains the block
+*> diagonal matrix D and the multipliers used to obtain the
+*> factor L or U from the block L*D*L' or U*D*U' factorization
+*> as computed by DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC. LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from DSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is DOUBLE PRECISION
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ RWORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ DOUBLE PRECISION ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASET, DLAVSY_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* Determine EPS and the norm of A.
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Initialize C to the identity matrix.
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC )
+*
+* Call DLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL DLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Call DLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL DLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
+ END IF
+*
+ RETURN
+*
+* End of DSYT01_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/schkaa.f b/lapack-netlib/TESTING/LIN/schkaa.f
index 0a471d25f..cbf16e610 100644
--- a/lapack-netlib/TESTING/LIN/schkaa.f
+++ b/lapack-netlib/TESTING/LIN/schkaa.f
@@ -158,9 +158,9 @@
EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ,
$ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3,
$ SCHKQL, SCHKQP, SCHKQR, SCHKRQ, SCHKSP, SCHKSY,
- $ SCHKTB, SCHKTP, SCHKTR, SCHKTZ,
+ $ SCHKSY_ROOK, SCHKTB, SCHKTP, SCHKTR, SCHKTZ,
$ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO,
- $ SDRVPP, SDRVPT, SDRVSP, SDRVSY,
+ $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK,
$ ILAVER, SCHKQRT, SCHKQRTP
* ..
* .. Scalars in Common ..
@@ -637,6 +637,32 @@
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* SR: symmetric indefinite matrices with Rook pivoting,
+* with rook (bounded Bunch-Kaufman) pivoting algorithm
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL SCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL SDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/schksy.f b/lapack-netlib/TESTING/LIN/schksy.f
index 5c698e5a4..aee800a69 100644
--- a/lapack-netlib/TESTING/LIN/schksy.f
+++ b/lapack-netlib/TESTING/LIN/schksy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
* XACT, WORK, RWORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NNB, NNS, NOUT
@@ -23,7 +23,7 @@
* REAL A( * ), AFAC( * ), AINV( * ), B( * ),
* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -134,14 +134,12 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is REAL array, dimension
-*> (NMAX*max(3,NSMAX))
+*> WORK is REAL array, dimension (NMAX*max(3,NSMAX))
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
-*> RWORK is REAL array, dimension
-*> (max(NMAX,2*NSMAX))
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
*> \endverbatim
*>
*> \param[out] IWORK
@@ -158,12 +156,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup single_lin
*
@@ -172,10 +170,10 @@
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -315,6 +313,9 @@
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
GO TO 160
END IF
*
@@ -357,11 +358,11 @@
50 CONTINUE
END IF
ELSE
- IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
+ IOFF = 0
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
@@ -373,6 +374,7 @@
*
* Set the last IZERO rows and columns to zero.
*
+ IOFF = 0
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
@@ -388,6 +390,7 @@
*
* End generate the test matrix A.
*
+*
* Do for each value of NB in NBVAL
*
DO 150 INB = 1, NNB
@@ -506,6 +509,8 @@
RCONDC = ZERO
GO TO 140
END IF
+*
+* Do for each value of NRHS in NSVAL.
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
@@ -585,7 +590,7 @@
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
-* Check error code from SSYRFS.
+* Check error code from SSYRFS and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSYRFS', INFO, 0, UPLO, N,
@@ -611,6 +616,9 @@
END IF
120 CONTINUE
NRUN = NRUN + 6
+*
+* End do for each value of NRHS in NSVAL.
+*
130 CONTINUE
*
*+ TEST 9
diff --git a/lapack-netlib/TESTING/LIN/schksy_rook.f b/lapack-netlib/TESTING/LIN/schksy_rook.f
new file mode 100644
index 000000000..23a84cd1c
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/schksy_rook.f
@@ -0,0 +1,830 @@
+*> \brief \b SCHKSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+* XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* REAL A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SCHKSY_ROOK tests SSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK,
+*> and -CON_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is REAL array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is REAL array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is REAL array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup single_lin
+*
+* =====================================================================
+ SUBROUTINE SCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+ $ XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ REAL A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK,
+ $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN,
+ $ NT
+ REAL ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN,
+ $ RCOND, RCONDC, STEMP
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS ), SDUMMY( 1 )
+* ..
+* .. External Functions ..
+ REAL SGET06, SLANGE, SLANSY
+ EXTERNAL SGET06, SLANGE, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY,
+ $ SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, SSYEVX,
+ $ SSYCON_ROOK, SSYT01_ROOK, SSYTRF_ROOK,
+ $ SSYTRI_ROOK, SSYTRS_ROOK, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Single precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Single precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL SERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with SLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with SLATMS.
+*
+ SRNAMT = 'SLATMS'
+ CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from SLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'SSYTRF_ROOK'
+ CALL SSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from SSYTRF_ROOK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'SSYTRF_ROOK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'SSYTRI_ROOK'
+ CALL SSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK,
+ $ INFO )
+*
+* Check error code from SSYTRI_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'SSYTRI_ROOK', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ONE / ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ STEMP = SLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ STEMP = SLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ STEMP = SLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ STEMP = SLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ONE+ALPHA ) / ( ONE-ALPHA )
+ CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in RWORK array
+*
+ CALL SSYEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-2 )*LDA+K-1 ), LDA, STEMP,
+ $ STEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, SDUMMY, 1, WORK, 16,
+ $ IWORK( N+1 ), IDUMMY, INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ STEMP = LAM_MAX / LAM_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = ABS( STEMP ) - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in RWORK array
+*
+ CALL SSYEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-1 )*LDA+K ), LDA, STEMP,
+ $ STEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, SDUMMY, 1, WORK, 16,
+ $ IWORK( N+1 ), IDUMMY, INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ STEMP = LAM_MAX / LAM_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = ABS( STEMP ) - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_ROOK)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'SLARHS'
+ CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'SSYTRS_ROOK'
+ CALL SSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from SSYTRS_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'SSYTRS_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'SSYCON_ROOK'
+ CALL SSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM,
+ $ RCOND, WORK, IWORK( N+1 ), INFO )
+*
+* Check error code from SSYCON_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'SSYCON_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = SGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of SCHKSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/sdrvpox.f b/lapack-netlib/TESTING/LIN/sdrvpox.f
index 8f4d2caa2..565b6c382 100644
--- a/lapack-netlib/TESTING/LIN/sdrvpox.f
+++ b/lapack-netlib/TESTING/LIN/sdrvpox.f
@@ -158,7 +158,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup single_lin
*
@@ -167,10 +167,10 @@
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -529,11 +529,12 @@
*
* Check the error code from SPOSVX.
*
- IF( INFO.NE.IZERO )
- $ CALL ALAERH( PATH, 'SPOSVX', INFO, IZERO,
+ IF( INFO.NE.IZERO ) THEN
+ CALL ALAERH( PATH, 'SPOSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
+ END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
diff --git a/lapack-netlib/TESTING/LIN/sdrvrfp.f b/lapack-netlib/TESTING/LIN/sdrvrfp.f
index df81d7cc4..c79b5a2c0 100644
--- a/lapack-netlib/TESTING/LIN/sdrvrfp.f
+++ b/lapack-netlib/TESTING/LIN/sdrvrfp.f
@@ -231,7 +231,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup single_lin
*
@@ -243,10 +243,10 @@
+ S_TEMP_SPOT03, S_WORK_SLANSY,
+ S_WORK_SPOT02, S_WORK_SPOT03 )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER NN, NNS, NNT, NOUT
@@ -342,7 +342,7 @@
*
* If N.EQ.0, only consider the first type
*
- IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120
+ IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
@@ -442,16 +442,19 @@
* Form the inverse of A.
*
CALL SPOTRI( UPLO, N, A, LDA, INFO )
+
+ IF ( N .NE. 0 ) THEN
*
-* Compute the 1-norm condition number of A.
+* Compute the 1-norm condition number of A.
*
- AINVNM = SLANSY( '1', UPLO, N, A, LDA,
+ AINVNM = SLANSY( '1', UPLO, N, A, LDA,
+ S_WORK_SLANSY )
- RCONDC = ( ONE / ANORM ) / AINVNM
+ RCONDC = ( ONE / ANORM ) / AINVNM
*
-* Restore the matrix A.
+* Restore the matrix A.
*
- CALL SLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
+ CALL SLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
+ END IF
*
END IF
*
diff --git a/lapack-netlib/TESTING/LIN/sdrvsy.f b/lapack-netlib/TESTING/LIN/sdrvsy.f
index 95fc002ce..1e3abeda1 100644
--- a/lapack-netlib/TESTING/LIN/sdrvsy.f
+++ b/lapack-netlib/TESTING/LIN/sdrvsy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
* NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NOUT, NRHS
@@ -23,7 +23,7 @@
* REAL A( * ), AFAC( * ), AINV( * ), B( * ),
* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -116,8 +116,7 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is REAL array, dimension
-*> (NMAX*max(2,NRHS))
+*> WORK is REAL array, dimension (NMAX*max(2,NRHS))
*> \endverbatim
*>
*> \param[out] RWORK
@@ -139,12 +138,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup single_lin
*
@@ -153,10 +152,10 @@
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
diff --git a/lapack-netlib/TESTING/LIN/sdrvsy_rook.f b/lapack-netlib/TESTING/LIN/sdrvsy_rook.f
new file mode 100644
index 000000000..e729dc51e
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/sdrvsy_rook.f
@@ -0,0 +1,527 @@
+*> \brief \b SDRVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+* $ RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* REAL A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SDRVSY_ROOK tests the driver routines SSYSV_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is REAL array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is REAL array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is REAL array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension
+*> (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE SDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ REAL A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ REAL AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ REAL SLANSY
+ EXTERNAL SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY,
+ $ SLARHS, SLASET, SLATB4, SLATMS, SPOT02, SPOT05,
+ $ SSYSV_ROOK, SSYT01_ROOK, SSYTRF_ROOK,
+ $ SSYTRI_ROOK,
+ $ XLAENV
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Single precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Single precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL SERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with SLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with SLATMS.
+*
+ SRNAMT = 'SLATMS'
+ CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from SLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of the
+* matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IOFF = 0
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number for comparison with
+* the value returned by DSYSVX_ROOK.
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+ CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL SSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+ CALL SSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK,
+ $ WORK, INFO )
+ AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'SLARHS'
+ CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test SSYSV_ROOK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* SSYSV_ROOK.
+*
+ SRNAMT = 'SSYSV_ROOK'
+ CALL SSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from SSYSV_ROOK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'SSYSV_ROOK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'SSYSV_ROOK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of SDRVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/serrsy.f b/lapack-netlib/TESTING/LIN/serrsy.f
index 11fdc4eab..18fda1997 100644
--- a/lapack-netlib/TESTING/LIN/serrsy.f
+++ b/lapack-netlib/TESTING/LIN/serrsy.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -86,9 +86,10 @@
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI,
- $ SSPTRS, SSYCON, SSYRFS, SSYTF2, SSYTRF, SSYTRI,
- $ SSYTRI2, SSYTRS
+ EXTERNAL ALAESM, CHKXER, SSPCON, SSYCON_ROOK, SSPRFS,
+ $ SSPTRF, SSPTRI, SSPTRS, SSYCON, SSYRFS, SSYTF2,
+ $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI,
+ $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -252,11 +253,91 @@
CALL SSYCON( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting.
+*
+* SSYTRF_ROOK
+*
+ SRNAMT = 'SSYTRF_ROOK'
+ INFOT = 1
+ CALL SSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* SSYTF2_ROOK
+*
+ SRNAMT = 'SSYTF2_ROOK'
+ INFOT = 1
+ CALL SSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* SSYTRI_ROOK
+*
+ SRNAMT = 'SSYTRI_ROOK'
+ INFOT = 1
+ CALL SSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* SSYTRS_ROOK
+*
+ SRNAMT = 'SSYTRS_ROOK'
+ INFOT = 1
+ CALL SSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* SSYCON_ROOK
+*
+ SRNAMT = 'SSYCON_ROOK'
+ INFOT = 1
+ CALL SSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
*
* Test error exits of the routines that use factorization
* of a symmetric indefinite packed matrix with patrial
* (Bunch-Kaufman) pivoting.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* SSPTRF
*
diff --git a/lapack-netlib/TESTING/LIN/serrsyx.f b/lapack-netlib/TESTING/LIN/serrsyx.f
index 48513d9dc..45ebc34d6 100644
--- a/lapack-netlib/TESTING/LIN/serrsyx.f
+++ b/lapack-netlib/TESTING/LIN/serrsyx.f
@@ -51,17 +51,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -93,8 +93,10 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI,
- $ SSPTRS, SSYCON, SSYRFS, SSYTF2, SSYTRF, SSYTRI,
- $ SSYTRI2, SSYTRS, SSYRFSX
+ $ SSPTRS, SSYCON, SSYCON_ROOK,SSYRFS, SSYTF2,
+ $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI,
+ $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK,
+ $ SSYRFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -136,8 +138,9 @@
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
-* Test error exits of the routines that use the Bunch-Kaufman
-* factorization of a symmetric indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) pivoting.
*
* SSYTRF
*
@@ -305,10 +308,91 @@
CALL SSYCON( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting.
+*
+* SSYTRF_ROOK
+*
+ SRNAMT = 'SSYTRF_ROOK'
+ INFOT = 1
+ CALL SSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* SSYTF2_ROOK
+*
+ SRNAMT = 'SSYTF2_ROOK'
+ INFOT = 1
+ CALL SSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* SSYTRI_ROOK
+*
+ SRNAMT = 'SSYTRI_ROOK'
+ INFOT = 1
+ CALL SSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* SSYTRS_ROOK
+*
+ SRNAMT = 'SSYTRS_ROOK'
+ INFOT = 1
+ CALL SSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use the Bunch-Kaufman
-* factorization of a symmetric indefinite packed matrix.
+* SSYCON_ROOK
+*
+ SRNAMT = 'SSYCON_ROOK'
+ INFOT = 1
+ CALL SSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO )
+ CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) pivoting.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* SSPTRF
*
diff --git a/lapack-netlib/TESTING/LIN/serrvx.f b/lapack-netlib/TESTING/LIN/serrvx.f
index 8445fa61a..c09ca3998 100644
--- a/lapack-netlib/TESTING/LIN/serrvx.f
+++ b/lapack-netlib/TESTING/LIN/serrvx.f
@@ -91,7 +91,7 @@
EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV,
$ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV,
$ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV,
- $ SSYSVX
+ $ SSYSV_ROOK, SSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -626,6 +626,24 @@
CALL SSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* SSYSV_ROOK
+*
+ SRNAMT = 'SSYSV_ROOK'
+ INFOT = 1
+ CALL SSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/serrvxx.f b/lapack-netlib/TESTING/LIN/serrvxx.f
index c5849e415..147e5ff13 100644
--- a/lapack-netlib/TESTING/LIN/serrvxx.f
+++ b/lapack-netlib/TESTING/LIN/serrvxx.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -92,7 +92,8 @@
EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV,
$ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV,
$ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV,
- $ SSYSVX, SGESVXX, SSYSVXX, SPOSVXX, SGBSVXX
+ $ SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX, SPOSVXX,
+ $ SGBSVXX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -886,6 +887,22 @@
$ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N,
$ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO )
CALL CHKXER( 'SSYSVXX', INFOT, NOUT, LERR, OK )
+*
+* SSYSV_ROOK
+*
+ SRNAMT = 'SSYSV_ROOK'
+ INFOT = 1
+ CALL SSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/slavsy.f b/lapack-netlib/TESTING/LIN/slavsy.f
index 5f78afb82..3c575e2d7 100644
--- a/lapack-netlib/TESTING/LIN/slavsy.f
+++ b/lapack-netlib/TESTING/LIN/slavsy.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
* LDB, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
@@ -19,7 +19,7 @@
* INTEGER IPIV( * )
* REAL A( LDA, * ), B( LDB, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -85,6 +85,7 @@
*> A is REAL array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by SSYTRF.
+*> Stored as a 2-D triangular matrix.
*> \endverbatim
*>
*> \param[in] LDA
@@ -141,12 +142,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup single_lin
*
@@ -154,10 +155,10 @@
SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
diff --git a/lapack-netlib/TESTING/LIN/slavsy_rook.f b/lapack-netlib/TESTING/LIN/slavsy_rook.f
new file mode 100644
index 000000000..55477bd96
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/slavsy_rook.f
@@ -0,0 +1,584 @@
+*> \brief \b SLAVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
+* LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIAG, TRANS, UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SLAVSY_ROOK performs one of the matrix-vector operations
+*> x := A*x or x := A'*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by SSYTRF_ROOK.
+*>
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
+*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'T': x := A'*x
+*> = 'C': x := A'*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by SSYTRF_ROOK.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by SSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup single_lin
+*
+* =====================================================================
+ SUBROUTINE SLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV,
+ $ B, LDB, INFO )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+ INTEGER J, K, KP
+ REAL D11, D12, D21, D22, T1, T2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAVSY_ROOK ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ NOUNIT = LSAME( DIAG, 'N' )
+*------------------------------------------
+*
+* Compute B := A * B (No transpose)
+*
+*------------------------------------------
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := U*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop forward applying the transformations.
+*
+ K = 1
+ 10 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 30
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block
+*
+* Multiply by the diagonal element if forming U * D.
+*
+ IF( NOUNIT )
+ $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformation.
+*
+ CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Interchange if P(K) .ne. I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K + 1
+ ELSE
+*
+* 2 x 2 pivot block
+*
+* Multiply by the diagonal block if forming U * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D12 = A( K, K+1 )
+ D21 = D12
+ DO 20 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 20 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformations.
+*
+ CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL SGER( K-1, NRHS, ONE, A( 1, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the first of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K + 2
+ END IF
+ GO TO 10
+ 30 CONTINUE
+*
+* Compute B := L*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
+*
+ ELSE
+*
+* Loop backward applying the transformations to B.
+*
+ K = N
+ 40 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+* Test the pivot index. If greater than zero, a 1 x 1
+* pivot was used, otherwise a 2 x 2 pivot was used.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block:
+*
+* Multiply by the diagonal element if forming L * D.
+*
+ IF( NOUNIT )
+ $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+ KP = IPIV( K )
+*
+* Apply the transformation.
+*
+ CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K - 1
+*
+ ELSE
+*
+* 2 x 2 pivot block:
+*
+* Multiply by the diagonal block if forming L * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D21 = A( K, K-1 )
+ D12 = D21
+ DO 50 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 50 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+*
+* Apply the transformation.
+*
+ CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+ CALL SGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1,
+ $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the second of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K - 2
+ END IF
+ GO TO 40
+ 60 CONTINUE
+ END IF
+*----------------------------------------
+*
+* Compute B := A' * B (transpose)
+*
+*----------------------------------------
+ ELSE
+*
+* Form B := U'*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop backward applying the transformations.
+*
+ K = N
+ 70 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 90
+*
+* 1 x 1 pivot block.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.GT.1 ) THEN
+*
+* Interchange if P(K) .ne. I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL SGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
+ $ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.GT.2 ) THEN
+*
+* Swap the second of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the first of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformations
+*
+ CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
+ $ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
+ $ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D12 = A( K-1, K )
+ D21 = D12
+ DO 80 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 80 CONTINUE
+ END IF
+ K = K - 2
+ END IF
+ GO TO 70
+ 90 CONTINUE
+*
+* Form B := L'*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
+* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
+*
+ ELSE
+*
+* Loop forward applying the L-transformations.
+*
+ K = 1
+ 100 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 120
+*
+* 1 x 1 pivot block
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.LT.N ) THEN
+*
+* Interchange if P(K) .ne. I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL SGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.LT.N-1 ) THEN
+*
+* Swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the second of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformation
+*
+ CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE,
+ $ B( K+1, 1 ), LDB )
+ CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE,
+ $ B( K, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D21 = A( K+1, K )
+ D12 = D21
+ DO 110 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 110 CONTINUE
+ END IF
+ K = K + 2
+ END IF
+ GO TO 100
+ 120 CONTINUE
+ END IF
+*
+ END IF
+ RETURN
+*
+* End of SLAVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/ssyt01.f b/lapack-netlib/TESTING/LIN/ssyt01.f
index 134189e0b..f1fb0b9c3 100644
--- a/lapack-netlib/TESTING/LIN/ssyt01.f
+++ b/lapack-netlib/TESTING/LIN/ssyt01.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
* RWORK, RESID )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDAFAC, LDC, N
@@ -21,7 +21,7 @@
* REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
* $ RWORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -111,12 +111,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup single_lin
*
@@ -124,10 +124,10 @@
SUBROUTINE SSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
diff --git a/lapack-netlib/TESTING/LIN/ssyt01_rook.f b/lapack-netlib/TESTING/LIN/ssyt01_rook.f
new file mode 100644
index 000000000..129e9dafe
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/ssyt01_rook.f
@@ -0,0 +1,223 @@
+*> \brief \b SSYT01_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
+* RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* REAL RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* $ RWORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYT01_ROOK reconstructs a symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> The original symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is REAL array, dimension (LDAFAC,N)
+*> The factored form of the matrix A. AFAC contains the block
+*> diagonal matrix D and the multipliers used to obtain the
+*> factor L or U from the block L*D*L' or U*D*U' factorization
+*> as computed by SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC. LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from SSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is REAL array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is REAL
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup single_lin
+*
+* =====================================================================
+ SUBROUTINE SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ REAL RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ RWORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ REAL ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSY
+ EXTERNAL LSAME, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASET, SLAVSY_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* Determine EPS and the norm of A.
+*
+ EPS = SLAMCH( 'Epsilon' )
+ ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Initialize C to the identity matrix.
+*
+ CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC )
+*
+* Call SLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL SLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Call SLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL SLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
+ END IF
+*
+ RETURN
+*
+* End of SSYT01_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zchkaa.f b/lapack-netlib/TESTING/LIN/zchkaa.f
index 6537762c2..1c8c6ca71 100644
--- a/lapack-netlib/TESTING/LIN/zchkaa.f
+++ b/lapack-netlib/TESTING/LIN/zchkaa.f
@@ -50,6 +50,7 @@
*> ZPB 8 List types on next line if 0 < NTYPES < 8
*> ZPT 12 List types on next line if 0 < NTYPES < 12
*> ZHE 10 List types on next line if 0 < NTYPES < 10
+*> ZHR 10 List types on next line if 0 < NTYPES < 10
*> ZHP 10 List types on next line if 0 < NTYPES < 10
*> ZSY 11 List types on next line if 0 < NTYPES < 11
*> ZSR 11 List types on next line if 0 < NTYPES < 11
@@ -101,17 +102,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16_lin
*
* =====================================================================
PROGRAM ZCHKAA
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* =====================================================================
*
@@ -158,13 +159,13 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE,
- $ ZCHKHP, ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPS, ZCHKPP,
- $ ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQP, ZCHKQR, ZCHKRQ,
- $ ZCHKSP, ZCHKSY, ZCHKTB, ZCHKTP,
- $ ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE,
- $ ZDRVHP, ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT,
- $ ZDRVSP, ZDRVSY, ILAVER, ZCHKQRT,
- $ ZCHKQRTP
+ $ ZCHKHE_ROOK, ZCHKHP, ZCHKLQ, ZCHKPB, ZCHKPO,
+ $ ZCHKPS, ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQP,
+ $ ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK,
+ $ ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE,
+ $ ZDRVGT, ZDRVHE, ZDRVHE_ROOK, ZDRVHP, ZDRVLS,
+ $ ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY,
+ $ ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -637,6 +638,32 @@
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* HR: Hermitian indefinite matrices,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
@@ -688,6 +715,32 @@
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* SR: symmetric indefinite matrices,
+* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+*
+ NTYPES = 11
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/zchkhe.f b/lapack-netlib/TESTING/LIN/zchkhe.f
index ab4d0c394..0b5a1a1aa 100644
--- a/lapack-netlib/TESTING/LIN/zchkhe.f
+++ b/lapack-netlib/TESTING/LIN/zchkhe.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE ZCHKHE( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
* XACT, WORK, RWORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NNB, NNS, NOUT
@@ -24,7 +24,7 @@
* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -135,14 +135,12 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX*16 array, dimension
-*> (NMAX*max(3,NSMAX))
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
-*> RWORK is DOUBLE PRECISION array, dimension
-*> (max(NMAX,2*NSMAX))
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
*> \endverbatim
*>
*> \param[out] IWORK
@@ -159,12 +157,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -173,10 +171,10 @@
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -196,6 +194,8 @@
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
INTEGER NTYPES
PARAMETER ( NTYPES = 10 )
INTEGER NTESTS
@@ -260,6 +260,11 @@
$ CALL ZERRHE( PATH, NOUT )
INFOT = 0
*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
@@ -289,22 +294,27 @@
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
-* Set up parameters with ZLATB4 and generate a test matrix
-* with ZLATMS.
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
*
CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
*
SRNAMT = 'ZLATMS'
CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
-* Check error code from ZLATMS.
+* Check error code from ZLATMS and handle error.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
GO TO 160
END IF
*
@@ -327,34 +337,34 @@
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDA
DO 20 I = 1, IZERO - 1
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
- A( IOFF ) = ZERO
+ A( IOFF ) = CZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
- A( IOFF ) = ZERO
+ A( IOFF ) = CZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
50 CONTINUE
END IF
ELSE
- IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
+ IOFF = 0
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
60 CONTINUE
IOFF = IOFF + LDA
70 CONTINUE
@@ -362,10 +372,11 @@
*
* Set the last IZERO rows and columns to zero.
*
+ IOFF = 0
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
- A( IOFF+I ) = ZERO
+ A( IOFF+I ) = CZERO
80 CONTINUE
IOFF = IOFF + LDA
90 CONTINUE
@@ -375,6 +386,9 @@
IZERO = 0
END IF
*
+* End generate test matrix A.
+*
+*
* Set the imaginary part of the diagonals.
*
CALL ZLAIPD( N, A, LDA+1, 0 )
@@ -382,13 +396,24 @@
* Do for each value of NB in NBVAL
*
DO 150 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
-* Compute the L*D*L' or U*D*U' factorization of the
-* matrix.
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
*
CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
LWORK = MAX( 2, NB )*LDA
SRNAMT = 'ZHETRF'
CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
@@ -411,11 +436,14 @@
END IF
END IF
*
-* Check error code from ZHETRF.
+* Check error code from ZHETRF and handle error.
*
IF( INFO.NE.K )
$ CALL ALAERH( PATH, 'ZHETRF', INFO, K, UPLO, N, N,
$ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
IF( INFO.NE.0 ) THEN
TRFCON = .TRUE.
ELSE
@@ -439,12 +467,15 @@
CALL ZHETRI2( UPLO, N, AINV, LDA, IWORK, WORK,
$ LWORK, INFO )
*
-* Check error code from ZHETRI.
+* Check error code from ZHETRI and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZHETRI', INFO, -1, UPLO, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
*
CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDC, RESULT( 2 ) )
@@ -477,12 +508,17 @@
RCONDC = ZERO
GO TO 140
END IF
+*
+* Do for each value of NRHS in NSVAL.
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
-*+ TEST 3
+*+ TEST 3 (Using TRS)
* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
*
SRNAMT = 'ZLARHS'
CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
@@ -494,7 +530,7 @@
CALL ZHETRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, INFO )
*
-* Check error code from ZHETRS.
+* Check error code from ZHETRS and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZHETRS', INFO, 0, UPLO, N,
@@ -502,11 +538,17 @@
$ NERRS, NOUT )
*
CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 3 ) )
*
-*+ TEST 4
+*+ TEST 4 (Using TRS2)
* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
*
SRNAMT = 'ZLARHS'
CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
@@ -518,7 +560,7 @@
CALL ZHETRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, WORK, INFO )
*
-* Check error code from ZSYTRS2.
+* Check error code from ZHETRS2 and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZHETRS2', INFO, 0, UPLO, N,
@@ -526,6 +568,9 @@
$ NERRS, NOUT )
*
CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 4 ) )
*
@@ -544,7 +589,7 @@
$ RWORK( NRHS+1 ), WORK,
$ RWORK( 2*NRHS+1 ), INFO )
*
-* Check error code from ZHERFS.
+* Check error code from ZHERFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZHERFS', INFO, 0, UPLO, N,
@@ -569,7 +614,10 @@
NFAIL = NFAIL + 1
END IF
120 CONTINUE
- NRUN = NRUN + 5
+ NRUN = NRUN + 6
+*
+* End do for each value of NRHS in NSVAL.
+*
130 CONTINUE
*
*+ TEST 9
@@ -581,7 +629,7 @@
CALL ZHECON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
$ WORK, INFO )
*
-* Check error code from ZHECON.
+* Check error code from ZHECON and handle error.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZHECON', INFO, 0, UPLO, N, N,
diff --git a/lapack-netlib/TESTING/LIN/zchkhe_rook.f b/lapack-netlib/TESTING/LIN/zchkhe_rook.f
new file mode 100644
index 000000000..0ec8def28
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zchkhe_rook.f
@@ -0,0 +1,844 @@
+*> \brief \b ZCHKHE_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+* XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCHKHE_ROOK tests ZHETRF_ROOK, -TRI_ROOK, -TRS_ROOK,
+*> and -CON_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is CCOMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is CCOMPLEX*16 array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+ $ XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ONEHALF
+ PARAMETER ( ONEHALF = 0.5D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN,
+ $ RCOND, RCONDC, DTEMP
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 )
+ DOUBLE PRECISION RESULT( NTESTS )
+ COMPLEX*16 CDUMMY( 1 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION ZLANGE, ZLANHE, DGET06
+ EXTERNAL ZLANGE, ZLANHE, DGET06
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, ZERRHE, ZHEEVX, ZGET04,
+ $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZPOT02,
+ $ ZPOT03, ZHECON_ROOK, ZHET01_ROOK, ZHETRF_ROOK,
+ $ ZHETRI_ROOK, ZHETRS_ROOK, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'HR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRHE( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from ZLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'ZHETRF_ROOK'
+ CALL ZHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZHETRF_ROOK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'ZHETRF_ROOK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'ZHETRI_ROOK'
+ CALL ZHETRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK,
+ $ INFO )
+*
+* Check error code from ZHETRI_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZHETRI_ROOK', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a Hermitian matrix times
+* its inverse.
+*
+ CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in U
+*
+ DTEMP = ZLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ DTEMP = ZLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in L
+*
+ DTEMP = ZLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ DTEMP = ZLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ CALL ZHEEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-2 )*LDA+K-1 ), LDA,DTEMP,
+ $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, CDUMMY, 1, WORK, 16,
+ $ RWORK( 3 ), IWORK( N+1 ), IDUMMY,
+ $ INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ DTEMP = LAM_MAX / LAM_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = ABS( DTEMP ) - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ CALL ZHEEVX( 'N', 'A', UPLO, 2,
+ $ AINV( ( K-1 )*LDA+K ), LDA, DTEMP,
+ $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP,
+ $ RWORK, CDUMMY, 1, WORK, 16,
+ $ RWORK( 3 ), IWORK( N+1 ), IDUMMY,
+ $ INFO )
+*
+ LAM_MAX = MAX( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( RWORK( 1 ) ),
+ $ ABS( RWORK( 2 ) ) )
+*
+ DTEMP = LAM_MAX / LAM_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = ABS( DTEMP ) - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+* Begin loop over NRHS values
+*
+*
+*+ TEST 5 ( Using TRS_ROOK)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'ZHETRS_ROOK'
+ CALL ZHETRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from ZHETRS_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZHETRS_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'ZHECON_ROOK'
+ CALL ZHECON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from ZHECON_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZHECON_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = DGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of ZCHKHE_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zchksy.f b/lapack-netlib/TESTING/LIN/zchksy.f
index df4c6d38c..d656ee221 100644
--- a/lapack-netlib/TESTING/LIN/zchksy.f
+++ b/lapack-netlib/TESTING/LIN/zchksy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE ZCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
* XACT, WORK, RWORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NNB, NNS, NOUT
@@ -24,7 +24,7 @@
* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -135,14 +135,12 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX*16 array, dimension
-*> (NMAX*max(2,NSMAX))
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NSMAX))
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
-*> RWORK is DOUBLE PRECISION array,
-*> dimension (NMAX+2*NSMAX)
+*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NSMAX)
*> \endverbatim
*>
*> \param[out] IWORK
@@ -159,12 +157,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -173,10 +171,10 @@
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -197,7 +195,7 @@
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
COMPLEX*16 CZERO
- PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
INTEGER NTYPES
PARAMETER ( NTYPES = 11 )
INTEGER NTESTS
@@ -298,11 +296,13 @@
*
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
+*
+* Begin generate test matrix A.
*
IF( IMAT.NE.NTYPES ) THEN
*
-* Set up parameters with ZLATB4 and generate a test
-* matrix with ZLATMS.
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
*
CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
$ MODE, CNDNUM, DIST )
@@ -319,6 +319,9 @@
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
GO TO 160
END IF
*
@@ -390,18 +393,20 @@
ELSE
IZERO = 0
END IF
-*
-* End generate the test matrix A.
*
ELSE
*
-* Use a special block diagonal matrix to test alternate
-* code for the 2 x 2 blocks.
+* For matrix kind IMAT = 11, generate special block
+* diagonal matrix to test alternate code
+* for the 2 x 2 blocks.
*
CALL ZLATSY( UPLO, N, A, LDA, ISEED )
*
END IF
*
+* End generate test matrix A.
+*
+*
* Do for each value of NB in NBVAL
*
DO 150 INB = 1, NNB
@@ -520,6 +525,8 @@
RCONDC = ZERO
GO TO 140
END IF
+*
+* Do for each value of NRHS in NSVAL.
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
@@ -626,6 +633,9 @@
END IF
120 CONTINUE
NRUN = NRUN + 6
+*
+* End do for each value of NRHS in NSVAL.
+*
130 CONTINUE
*
*+ TEST 9
@@ -643,7 +653,7 @@
$ CALL ALAERH( PATH, 'ZSYCON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
-* Compute the test ratio to compare to values of RCOND
+* Compute the test ratio to compare values of RCOND
*
RESULT( 9 ) = DGET06( RCOND, RCONDC )
*
diff --git a/lapack-netlib/TESTING/LIN/zchksy_rook.f b/lapack-netlib/TESTING/LIN/zchksy_rook.f
new file mode 100644
index 000000000..3b93b6fe6
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zchksy_rook.f
@@ -0,0 +1,860 @@
+*> \brief \b ZCHKSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+* XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCHKSY_ROOK tests ZSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK,
+*> and -CON_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+ $ XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ONEHALF
+ PARAMETER ( ONEHALF = 0.5D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 11 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, LAM_MAX,
+ $ LAM_MIN, RCOND, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+ COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DGET06, ZLANGE, ZLANSY
+ EXTERNAL DGET06, ZLANGE, ZLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, ZERRSY, ZGEEVX, ZGET04,
+ $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY,ZSYT02,
+ $ ZSYT03, ZSYCON_ROOK, ZSYT01_ROOK, ZSYTRF_ROOK,
+ $ ZSYTRI_ROOK, ZSYTRS_ROOK, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate test matrix A.
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from ZLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+ ELSE
+*
+* For matrix kind IMAT = 11, generate special block
+* diagonal matrix to test alternate code
+* for the 2 x 2 blocks.
+*
+ CALL ZLATSY( UPLO, N, A, LDA, ISEED )
+*
+ END IF
+*
+* End generate test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'ZSYTRF_ROOK'
+ CALL ZSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZSYTRF_ROOK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'ZSYTRF_ROOK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'ZSYTRI_ROOK'
+ CALL ZSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK,
+ $ INFO )
+*
+* Check error code from ZSYTRI_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZSYTRI_ROOK', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ DTEMP = ZLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ DTEMP = ZLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ DTEMP = ZLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ DTEMP = ZLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 2, 1 ) = AFAC( ( K-2 )*LDA+K )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL ZGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK,
+ $ 2, WORK, ZDUMMY, 1, ZDUMMY, 1,
+ $ ITEMP, ITEMP2, RWORK, DTEMP,
+ $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ),
+ $ 4, RWORK( 7 ), INFO )
+*
+ LAM_MAX = MAX( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+*
+ DTEMP = LAM_MAX / LAM_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = ABS( DTEMP ) - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two eigenvalues of a 2-by-2 block,
+* store them in WORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = AFAC( ( K-1 )*LDA+K+1 )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL ZGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK,
+ $ 2, WORK, ZDUMMY, 1, ZDUMMY, 1,
+ $ ITEMP, ITEMP2, RWORK, DTEMP,
+ $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ),
+ $ 4, RWORK( 7 ), INFO )
+*
+ LAM_MAX = MAX( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+ LAM_MIN = MIN( ABS( WORK( 1 ) ),
+ $ ABS( WORK( 2 ) ) )
+*
+ DTEMP = LAM_MAX / LAM_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = ABS( DTEMP ) - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_ROOK)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'ZSYTRS_ROOK'
+ CALL ZSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from ZSYTRS_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZSYTRS_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'ZSYCON_ROOK'
+ CALL ZSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from ZSYCON_ROOK and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZSYCON_ROOK', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = DGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of ZCHKSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zdrvhe.f b/lapack-netlib/TESTING/LIN/zdrvhe.f
index 7c9fd7c7e..ba8f28fa9 100644
--- a/lapack-netlib/TESTING/LIN/zdrvhe.f
+++ b/lapack-netlib/TESTING/LIN/zdrvhe.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE ZDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
* NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NOUT, NRHS
@@ -24,7 +24,7 @@
* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -117,8 +117,7 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX*16 array, dimension
-*> (NMAX*max(2,NRHS))
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
*> \endverbatim
*>
*> \param[out] RWORK
@@ -140,12 +139,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -154,10 +153,10 @@
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -226,7 +225,7 @@
*
* Initialize constants and the random number seed.
*
- PATH( 1: 1 ) = 'Z'
+ PATH( 1: 1 ) = 'Zomplex precision'
PATH( 2: 3 ) = 'HE'
NRUN = 0
NFAIL = 0
diff --git a/lapack-netlib/TESTING/LIN/zdrvhe_rook.f b/lapack-netlib/TESTING/LIN/zdrvhe_rook.f
new file mode 100644
index 000000000..70fed11dd
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zdrvhe_rook.f
@@ -0,0 +1,528 @@
+*> \brief \b ZDRVHE_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
+* IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZDRVHE_ROOK tests the driver routines ZHESV_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION ZLANHE
+ EXTERNAL ZLANHE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX,
+ $ ZGET04, ZLACPY, ZLARHS, ZLATB4, ZLATMS,
+ $ ZHESV_ROOK, ZHET01_ROOK, ZPOT02,
+ $ ZHETRF_ROOK, ZHETRI_ROOK
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'HR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from ZLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number for comparison with
+* the value returned by ZHESVX_ROOK.
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+ CALL ZHETRI_ROOK( UPLO, N, AINV, LDA, IWORK,
+ $ WORK, INFO )
+ AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test ZHESV_ROOK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* ZHESV_ROOK.
+*
+ SRNAMT = 'ZHESV_ROOK'
+ CALL ZHESV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZHESV_ROOK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'ZHESV_ROOK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'ZHESV_ROOK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of ZDRVHE_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zdrvpox.f b/lapack-netlib/TESTING/LIN/zdrvpox.f
index 7613117a5..3242f08eb 100644
--- a/lapack-netlib/TESTING/LIN/zdrvpox.f
+++ b/lapack-netlib/TESTING/LIN/zdrvpox.f
@@ -153,7 +153,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -162,10 +162,10 @@
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
@@ -530,11 +530,12 @@
*
* Check the error code from ZPOSVX.
*
- IF( INFO.NE.IZERO )
- $ CALL ALAERH( PATH, 'ZPOSVX', INFO, IZERO,
+ IF( INFO.NE.IZERO ) THEN
+ CALL ALAERH( PATH, 'ZPOSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
+ END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
diff --git a/lapack-netlib/TESTING/LIN/zdrvrfp.f b/lapack-netlib/TESTING/LIN/zdrvrfp.f
index 6efc625c3..e101abafa 100644
--- a/lapack-netlib/TESTING/LIN/zdrvrfp.f
+++ b/lapack-netlib/TESTING/LIN/zdrvrfp.f
@@ -232,7 +232,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -244,10 +244,10 @@
+ Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE,
+ D_WORK_ZPOT01, D_WORK_ZPOT02, D_WORK_ZPOT03 )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
INTEGER NN, NNS, NNT, NOUT
@@ -345,7 +345,7 @@
*
* If N.EQ.0, only consider the first type
*
- IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120
+ IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
@@ -449,16 +449,19 @@
* Form the inverse of A.
*
CALL ZPOTRI( UPLO, N, A, LDA, INFO )
+
+ IF ( N .NE. 0 ) THEN
*
-* Compute the 1-norm condition number of A.
+* Compute the 1-norm condition number of A.
*
- AINVNM = ZLANHE( '1', UPLO, N, A, LDA,
+ AINVNM = ZLANHE( '1', UPLO, N, A, LDA,
+ D_WORK_ZLANHE )
- RCONDC = ( ONE / ANORM ) / AINVNM
+ RCONDC = ( ONE / ANORM ) / AINVNM
*
-* Restore the matrix A.
+* Restore the matrix A.
*
- CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
+ CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
+ END IF
*
END IF
*
diff --git a/lapack-netlib/TESTING/LIN/zdrvsy.f b/lapack-netlib/TESTING/LIN/zdrvsy.f
index 5fa0e64ee..5e0c60e23 100644
--- a/lapack-netlib/TESTING/LIN/zdrvsy.f
+++ b/lapack-netlib/TESTING/LIN/zdrvsy.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -11,7 +11,7 @@
* SUBROUTINE ZDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
* NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NMAX, NN, NOUT, NRHS
@@ -24,7 +24,7 @@
* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
* $ WORK( * ), X( * ), XACT( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -117,8 +117,7 @@
*>
*> \param[out] WORK
*> \verbatim
-*> WORK is COMPLEX*16 array, dimension
-*> (NMAX*max(2,NRHS))
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
*> \endverbatim
*>
*> \param[out] RWORK
@@ -140,12 +139,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -154,10 +153,10 @@
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
LOGICAL TSTERR
diff --git a/lapack-netlib/TESTING/LIN/zdrvsy_rook.f b/lapack-netlib/TESTING/LIN/zdrvsy_rook.f
new file mode 100644
index 000000000..0718a9838
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zdrvsy_rook.f
@@ -0,0 +1,534 @@
+*> \brief \b ZDRVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
+* IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZDRVSY_ROOK tests the driver routines ZSYSV_ROOK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 11, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION ZLANSY
+ EXTERNAL ZLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04,
+ $ ZLACPY, ZLARHS, ZLASET, ZLATB4, ZLATMS, ZLATSY,
+ $ ZPOT05, ZSYSV_ROOK, ZSYT01_ROOK, ZSYT02,
+ $ ZSYTRF_ROOK, ZSYTRI_ROOK
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'SR'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from DLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+ ELSE
+*
+* IMAT = NTYPES: Use a special block diagonal matrix to
+* test alternate code for the 2-by-2 blocks.
+*
+ CALL ZLATSY( UPLO, N, A, LDA, ISEED )
+ END IF
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number for comparison with
+* the value returned by ZSYSVX_ROOK.
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+ CALL ZSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK,
+ $ WORK, INFO )
+ AINVNM = ZLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test ZSYSV_ROOK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* ZSYSV_ROOK.
+*
+ SRNAMT = 'ZSYSV_ROOK'
+ CALL ZSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZSYSV_ROOK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'ZSYSV_ROOK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'ZSYSV_ROOK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of ZDRVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zerrhe.f b/lapack-netlib/TESTING/LIN/zerrhe.f
index 4d88e7388..600662889 100644
--- a/lapack-netlib/TESTING/LIN/zerrhe.f
+++ b/lapack-netlib/TESTING/LIN/zerrhe.f
@@ -2,19 +2,19 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZERRHE( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -43,22 +43,22 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -88,9 +88,11 @@
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, ZHECON, ZHERFS, ZHETF2, ZHETRF,
- $ ZHETRI, ZHETRI2, ZHETRS, ZHPCON, ZHPRFS,
- $ ZHPTRF, ZHPTRI, ZHPTRS
+ EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS,
+ $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK,
+ $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS,
+ $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI,
+ $ ZHPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -129,8 +131,9 @@
ANRM = 1.0D0
OK = .TRUE.
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
@@ -253,8 +256,89 @@
CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite packed matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* ZHETRF_ROOK
+*
+ SRNAMT = 'ZHETRF_ROOK'
+ INFOT = 1
+ CALL ZHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHETF2_ROOK
+*
+ SRNAMT = 'ZHETF2_ROOK'
+ INFOT = 1
+ CALL ZHETF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHETRI_ROOK
+*
+ SRNAMT = 'ZHETRI_ROOK'
+ INFOT = 1
+ CALL ZHETRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHETRS_ROOK
+*
+ SRNAMT = 'ZHETRS_ROOK'
+ INFOT = 1
+ CALL ZHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHECON_ROOK
+*
+ SRNAMT = 'ZHECON_ROOK'
+ INFOT = 1
+ CALL ZHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/zerrhex.f b/lapack-netlib/TESTING/LIN/zerrhex.f
index 7dafede06..49c07df1d 100644
--- a/lapack-netlib/TESTING/LIN/zerrhex.f
+++ b/lapack-netlib/TESTING/LIN/zerrhex.f
@@ -51,17 +51,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -94,9 +94,11 @@
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, ZHECON, ZHERFS, ZHETF2, ZHETRF,
- $ ZHETRI, ZHETRI2, ZHETRS, ZHPCON, ZHPRFS,
- $ ZHPTRF, ZHPTRI, ZHPTRS, ZHERFSX
+ EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS,
+ $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK,
+ $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS,
+ $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI,
+ $ ZHPTRS, ZHERFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -136,8 +138,9 @@
ANRM = 1.0D0
OK = .TRUE.
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
@@ -307,8 +310,89 @@
CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a Hermitian indefinite packed matrix.
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* ZHETRF_ROOK
+*
+ SRNAMT = 'ZHETRF_ROOK'
+ INFOT = 1
+ CALL ZHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHETF2_ROOK
+*
+ SRNAMT = 'ZHETF2_ROOK'
+ INFOT = 1
+ CALL ZHETF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHETRI_ROOK
+*
+ SRNAMT = 'ZHETRI_ROOK'
+ INFOT = 1
+ CALL ZHETRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHETRS_ROOK
+*
+ SRNAMT = 'ZHETRS_ROOK'
+ INFOT = 1
+ CALL ZHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZHECON_ROOK
+*
+ SRNAMT = 'ZHECON_ROOK'
+ INFOT = 1
+ CALL ZHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/zerrsy.f b/lapack-netlib/TESTING/LIN/zerrsy.f
index b6bc4b048..a9126a12f 100644
--- a/lapack-netlib/TESTING/LIN/zerrsy.f
+++ b/lapack-netlib/TESTING/LIN/zerrsy.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -88,8 +88,9 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI,
- $ ZSPTRS, ZSYCON, ZSYRFS, ZSYTF2, ZSYTRF, ZSYTRI,
- $ ZSYTRI2, ZSYTRS
+ $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2,
+ $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI,
+ $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -128,11 +129,11 @@
ANRM = 1.0D0
OK = .TRUE.
*
- IF( LSAMEN( 2, C2, 'SY' ) ) THEN
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with patrial
-* (Bunch-Kaufman) pivoting.
+ IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* ZSYTRF
*
@@ -253,11 +254,91 @@
CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* ZSYTRF_ROOK
+*
+ SRNAMT = 'ZSYTRF_ROOK'
+ INFOT = 1
+ CALL ZSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTF2_ROOK
+*
+ SRNAMT = 'ZSYTF2_ROOK'
+ INFOT = 1
+ CALL ZSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRI_ROOK
+*
+ SRNAMT = 'ZSYTRI_ROOK'
+ INFOT = 1
+ CALL ZSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRS_ROOK
+*
+ SRNAMT = 'ZSYTRS_ROOK'
+ INFOT = 1
+ CALL ZSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYCON_ROOK
+*
+ SRNAMT = 'ZSYCON_ROOK'
+ INFOT = 1
+ CALL ZSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
*
* Test error exits of the routines that use factorization
* of a symmetric indefinite packed matrix with patrial
* (Bunch-Kaufman) pivoting.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* ZSPTRF
*
diff --git a/lapack-netlib/TESTING/LIN/zerrsyx.f b/lapack-netlib/TESTING/LIN/zerrsyx.f
index 3da57aea1..601c6ab63 100644
--- a/lapack-netlib/TESTING/LIN/zerrsyx.f
+++ b/lapack-netlib/TESTING/LIN/zerrsyx.f
@@ -51,17 +51,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -94,8 +94,10 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI,
- $ ZSPTRS, ZSYCON, ZSYRFS, ZSYTF2, ZSYTRF, ZSYTRI,
- $ ZSYTRI2, ZSYTRS, ZSYRFSX
+ $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2,
+ $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI,
+ $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK,
+ $ ZSYRFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -135,8 +137,9 @@
ANRM = 1.0D0
OK = .TRUE.
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a symmetric indefinite matrix.
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
@@ -306,8 +309,89 @@
CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use the diagonal pivoting
-* factorization of a symmetric indefinite packed matrix.
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with "rook"
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* ZSYTRF_ROOK
+*
+ SRNAMT = 'ZSYTRF_ROOK'
+ INFOT = 1
+ CALL ZSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTF2_ROOK
+*
+ SRNAMT = 'ZSYTF2_ROOK'
+ INFOT = 1
+ CALL ZSYTF2_ROOK( '/', 0, A, 1, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTF2_ROOK( 'U', -1, A, 1, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTF2_ROOK( 'U', 2, A, 1, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRI_ROOK
+*
+ SRNAMT = 'ZSYTRI_ROOK'
+ INFOT = 1
+ CALL ZSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO )
+ CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRS_ROOK
+*
+ SRNAMT = 'ZSYTRS_ROOK'
+ INFOT = 1
+ CALL ZSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK )
+*
+* ZSYCON_ROOK
+*
+ SRNAMT = 'ZSYCON_ROOK'
+ INFOT = 1
+ CALL ZSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) pivoting.
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/zerrvx.f b/lapack-netlib/TESTING/LIN/zerrvx.f
index ddbb90707..057bf872b 100644
--- a/lapack-netlib/TESTING/LIN/zerrvx.f
+++ b/lapack-netlib/TESTING/LIN/zerrvx.f
@@ -2,8 +2,8 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -90,10 +90,10 @@
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV,
- $ ZGTSVX, ZHESV, ZHESVX, ZHPSV, ZHPSVX, ZPBSV,
- $ ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, ZPPSVX, ZPTSV,
- $ ZPTSVX, ZSPSV, ZSPSVX, ZSYSV,
- $ ZSYSVX
+ $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV,
+ $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV,
+ $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV,
+ $ ZSYSV_ROOK, ZSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -633,6 +633,24 @@
CALL ZHESVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, RW, INFO )
CALL CHKXER( 'ZHESVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* ZHESV_ROOK
+*
+ SRNAMT = 'ZHESV_ROOK'
+ INFOT = 1
+ CALL ZHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
@@ -737,6 +755,24 @@
CALL ZSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, RW, INFO )
CALL CHKXER( 'ZSYSVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* ZSYSV_ROOK
+*
+ SRNAMT = 'ZSYSV_ROOK'
+ INFOT = 1
+ CALL ZSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/zerrvxx.f b/lapack-netlib/TESTING/LIN/zerrvxx.f
index 09bc746d5..c974c3b42 100644
--- a/lapack-netlib/TESTING/LIN/zerrvxx.f
+++ b/lapack-netlib/TESTING/LIN/zerrvxx.f
@@ -48,17 +48,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
@@ -91,10 +91,11 @@
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV,
- $ ZGTSVX, ZHESV, ZHESVX, ZHPSV, ZHPSVX, ZPBSV,
- $ ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, ZPPSVX, ZPTSV,
- $ ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, ZSYSVX, ZGESVXX,
- $ ZSYSVXX, ZPOSVXX, ZHESVXX, ZGBSVXX
+ $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV,
+ $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV,
+ $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV,
+ $ ZSYSV_ROOK, ZSYSVX, ZGESVXX, ZSYSVXX, ZPOSVXX,
+ $ ZHESVXX, ZGBSVXX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
@@ -499,6 +500,24 @@
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 2, X, 1, RCOND, R1, R2, W, RW, INFO )
CALL CHKXER( 'ZGTSVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* ZHESV_ROOK
+*
+ SRNAMT = 'ZHESV_ROOK'
+ INFOT = 1
+ CALL ZHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
@@ -912,6 +931,24 @@
$ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N,
$ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO )
CALL CHKXER( 'ZHESVXX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+*
+* ZHESV_ROOK
+*
+ SRNAMT = 'ZHESV_ROOK'
+ INFOT = 1
+ CALL ZHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
@@ -1066,6 +1103,25 @@
$ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N,
$ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO )
CALL CHKXER( 'ZSYSVXX', INFOT, NOUT, LERR, OK )
+ CALL CHKXER( 'ZSYSVX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* ZSYSV_ROOK
+*
+ SRNAMT = 'ZSYSV_ROOK'
+ INFOT = 1
+ CALL ZSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
diff --git a/lapack-netlib/TESTING/LIN/zhet01.f b/lapack-netlib/TESTING/LIN/zhet01.f
index 5b3ecee37..b8ec93ac9 100644
--- a/lapack-netlib/TESTING/LIN/zhet01.f
+++ b/lapack-netlib/TESTING/LIN/zhet01.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
* RWORK, RESID )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDAFAC, LDC, N
@@ -21,7 +21,7 @@
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -113,12 +113,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -126,10 +126,10 @@
SUBROUTINE ZHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
diff --git a/lapack-netlib/TESTING/LIN/zhet01_rook.f b/lapack-netlib/TESTING/LIN/zhet01_rook.f
new file mode 100644
index 000000000..8474c2577
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zhet01_rook.f
@@ -0,0 +1,239 @@
+*> \brief \b ZHET01_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
+* RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHET01_ROOK reconstructs a complex Hermitian indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix, EPS is the machine epsilon,
+*> L' is the transpose of L, and U' is the transpose of U.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> complex Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The original complex Hermitian matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
+*> The factored form of the matrix A. AFAC contains the block
+*> diagonal matrix D and the multipliers used to obtain the
+*> factor L or U from the block L*D*L' or U*D*U' factorization
+*> as computed by CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC. LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from CSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is DOUBLE PRECISION
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ COMPLEX*16 CZERO, CONE
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
+ $ CONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ DOUBLE PRECISION ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION ZLANHE, DLAMCH
+ EXTERNAL LSAME, ZLANHE, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLASET, ZLAVHE_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DIMAG, DBLE
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* Determine EPS and the norm of A.
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Check the imaginary parts of the diagonal elements and return with
+* an error code if any are nonzero.
+*
+ DO 10 J = 1, N
+ IF( DIMAG( AFAC( J, J ) ).NE.ZERO ) THEN
+ RESID = ONE / EPS
+ RETURN
+ END IF
+ 10 CONTINUE
+*
+* Initialize C to the identity matrix.
+*
+ CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* Call ZLAVHE_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL ZLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Call ZLAVHE_ROOK again to multiply by U (or L ).
+*
+ CALL ZLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 30 J = 1, N
+ DO 20 I = 1, J - 1
+ C( I, J ) = C( I, J ) - A( I, J )
+ 20 CONTINUE
+ C( J, J ) = C( J, J ) - DBLE( A( J, J ) )
+ 30 CONTINUE
+ ELSE
+ DO 50 J = 1, N
+ C( J, J ) = C( J, J ) - DBLE( A( J, J ) )
+ DO 40 I = J + 1, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+* Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = ZLANHE( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID/DBLE( N ) )/ANORM ) / EPS
+ END IF
+*
+ RETURN
+*
+* End of ZHET01_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zlatb4.f b/lapack-netlib/TESTING/LIN/zlatb4.f
index 93f8bc6bc..44db6e8f1 100644
--- a/lapack-netlib/TESTING/LIN/zlatb4.f
+++ b/lapack-netlib/TESTING/LIN/zlatb4.f
@@ -61,7 +61,8 @@
*> TYPE is CHARACTER*1
*> The type of the matrix to be generated:
*> = 'S': symmetric matrix
-*> = 'P': symmetric positive (semi)definite matrix
+*> = 'H': Hermitian matrix
+*> = 'P': Hermitian positive (semi)definite matrix
*> = 'N': nonsymmetric matrix
*> \endverbatim
*>
@@ -112,7 +113,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -120,10 +121,10 @@
SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIST, TYPE
diff --git a/lapack-netlib/TESTING/LIN/zlavhe.f b/lapack-netlib/TESTING/LIN/zlavhe.f
index fd0bedcb2..bf58d7d74 100644
--- a/lapack-netlib/TESTING/LIN/zlavhe.f
+++ b/lapack-netlib/TESTING/LIN/zlavhe.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
* LDB, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
@@ -19,118 +19,133 @@
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> ZLAVHE performs one of the matrix-vector operations
-*> x := A*x or x := A^H*x,
-*> where x is an N element vector and A is one of the factors
-*> from the symmetric factorization computed by ZHETRF.
-*> ZHETRF produces a factorization of the form
-*> U * D * U^H or L * D * L^H,
-*> where U (or L) is a product of permutation and unit upper (lower)
-*> triangular matrices, U^H (or L^H) is the conjugate transpose of
-*> U (or L), and D is Hermitian and block diagonal with 1 x 1 and
-*> 2 x 2 diagonal blocks. The multipliers for the transformations
-*> and the upper or lower triangular parts of the diagonal blocks
-*> are stored in the leading upper or lower triangle of the 2-D
-*> array A.
+*> ZLAVHE performs one of the matrix-vector operations
+*> x := A*x or x := A^H*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by ZHETRF.
*>
-*> If TRANS = 'N' or 'n', ZLAVHE multiplies either by U or U * D
-*> (or L or L * D).
-*> If TRANS = 'C' or 'c', ZLAVHE multiplies either by U^H or D * U^H
-*> (or L^H or D * L^H ).
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
*> \endverbatim
*
* Arguments:
* ==========
*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'C': x := A'*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
*> \verbatim
-*> UPLO - CHARACTER*1
-*> On entry, UPLO specifies whether the triangular matrix
-*> stored in A is upper or lower triangular.
-*> UPLO = 'U' or 'u' The matrix is upper triangular.
-*> UPLO = 'L' or 'l' The matrix is lower triangular.
-*> Unchanged on exit.
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
*>
-*> TRANS - CHARACTER*1
-*> On entry, TRANS specifies the operation to be performed as
-*> follows:
-*> TRANS = 'N' or 'n' x := A*x.
-*> TRANS = 'C' or 'c' x := A^H*x.
-*> Unchanged on exit.
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by ZHETRF.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
*>
-*> DIAG - CHARACTER*1
-*> On entry, DIAG specifies whether the diagonal blocks are
-*> assumed to be unit matrices:
-*> DIAG = 'U' or 'u' Diagonal blocks are unit matrices.
-*> DIAG = 'N' or 'n' Diagonal blocks are non-unit.
-*> Unchanged on exit.
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
*>
-*> N - INTEGER
-*> On entry, N specifies the order of the matrix A.
-*> N must be at least zero.
-*> Unchanged on exit.
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by ZHETRF.
*>
-*> NRHS - INTEGER
-*> On entry, NRHS specifies the number of right hand sides,
-*> i.e., the number of vectors x to be multiplied by A.
-*> NRHS must be at least zero.
-*> Unchanged on exit.
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
*>
-*> A - COMPLEX*16 array, dimension( LDA, N )
-*> On entry, A contains a block diagonal matrix and the
-*> multipliers of the transformations used to obtain it,
-*> stored as a 2-D triangular matrix.
-*> Unchanged on exit.
+*> If IPIV(k) = IPIV(k-1) < 0, then rows and
+*> columns k-1 and -IPIV(k) were interchanged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
-*> LDA - INTEGER
-*> On entry, LDA specifies the first dimension of A as declared
-*> in the calling ( sub ) program. LDA must be at least
-*> max( 1, N ).
-*> Unchanged on exit.
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
*>
-*> IPIV - INTEGER array, dimension( N )
-*> On entry, IPIV contains the vector of pivot indices as
-*> determined by ZSYTRF or ZHETRF.
-*> If IPIV( K ) = K, no interchange was done.
-*> If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter-
-*> changed with row IPIV( K ) and a 1 x 1 pivot block was used.
-*> If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged
-*> with row | IPIV( K ) | and a 2 x 2 pivot block was used.
-*> If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged
-*> with row | IPIV( K ) | and a 2 x 2 pivot block was used.
+*> If IPIV(k) = IPIV(k+1) < 0, then rows and
+*> columns k+1 and -IPIV(k) were interchanged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
*>
-*> B - COMPLEX*16 array, dimension( LDB, NRHS )
-*> On entry, B contains NRHS vectors of length N.
-*> On exit, B is overwritten with the product A * B.
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
*>
-*> LDB - INTEGER
-*> On entry, LDB contains the leading dimension of B as
-*> declared in the calling program. LDB must be at least
-*> max( 1, N ).
-*> Unchanged on exit.
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
*>
-*> INFO - INTEGER
-*> INFO is the error flag.
-*> On exit, a value of 0 indicates a successful exit.
-*> A negative value, say -K, indicates that the K-th argument
-*> has an illegal value.
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -138,10 +153,10 @@
SUBROUTINE ZLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
diff --git a/lapack-netlib/TESTING/LIN/zlavhe_rook.f b/lapack-netlib/TESTING/LIN/zlavhe_rook.f
new file mode 100644
index 000000000..b8e708f50
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zlavhe_rook.f
@@ -0,0 +1,600 @@
+*> \brief \b ZLAVHE_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
+* LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIAG, TRANS, UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> ZLAVHE_ROOK performs one of the matrix-vector operations
+*> x := A*x or x := A^H*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by ZHETRF_ROOK.
+*>
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'C': x := A^H*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by ZHETRF_ROOK.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by ZHETRF_ROOK.
+*> If UPLO = 'U':
+*> Only the last KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*> interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> Only the first KB elements of IPIV are set.
+*>
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV,
+ $ B, LDB, INFO )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 CONE
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+ INTEGER J, K, KP
+ COMPLEX*16 D11, D12, D21, D22, T1, T2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEMV, ZGERU, ZLACGV, ZSCAL, ZSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DCONJG, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZLAVHE_ROOK ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ NOUNIT = LSAME( DIAG, 'N' )
+*------------------------------------------
+*
+* Compute B := A * B (No transpose)
+*
+*------------------------------------------
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := U*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop forward applying the transformations.
+*
+ K = 1
+ 10 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 30
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block
+*
+* Multiply by the diagonal element if forming U * D.
+*
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformation.
+*
+ CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K + 1
+ ELSE
+*
+* 2 x 2 pivot block
+*
+* Multiply by the diagonal block if forming U * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D12 = A( K, K+1 )
+ D21 = DCONJG( D12 )
+ DO 20 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 20 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformations.
+*
+ CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL ZGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the first of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K + 2
+ END IF
+ GO TO 10
+ 30 CONTINUE
+*
+* Compute B := L*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
+*
+ ELSE
+*
+* Loop backward applying the transformations to B.
+*
+ K = N
+ 40 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+* Test the pivot index. If greater than zero, a 1 x 1
+* pivot was used, otherwise a 2 x 2 pivot was used.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block:
+*
+* Multiply by the diagonal element if forming L * D.
+*
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+ KP = IPIV( K )
+*
+* Apply the transformation.
+*
+ CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K - 1
+*
+ ELSE
+*
+* 2 x 2 pivot block:
+*
+* Multiply by the diagonal block if forming L * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D21 = A( K, K-1 )
+ D12 = DCONJG( D21 )
+ DO 50 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 50 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+*
+* Apply the transformation.
+*
+ CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+ CALL ZGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1,
+ $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+*
+* Swap the second of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+ END IF
+ K = K - 2
+ END IF
+ GO TO 40
+ 60 CONTINUE
+ END IF
+*--------------------------------------------------
+*
+* Compute B := A^H * B (conjugate transpose)
+*
+*--------------------------------------------------
+ ELSE
+*
+* Form B := U^H*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m)
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop backward applying the transformations.
+*
+ K = N
+ 70 IF( K.LT.1 )
+ $ GO TO 90
+*
+* 1 x 1 pivot block.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.GT.1 ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+* y = y - B' DCONJG(x),
+* where x is a column of A and y is a row of B.
+*
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate', K-1, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.GT.2 ) THEN
+*
+* Swap the second of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the first of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformations
+* y = y - B' DCONJG(x),
+* where x is a block column of A and y is a block
+* row of B.
+*
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+*
+ CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D12 = A( K-1, K )
+ D21 = DCONJG( D12 )
+ DO 80 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 80 CONTINUE
+ END IF
+ K = K - 2
+ END IF
+ GO TO 70
+ 90 CONTINUE
+*
+* Form B := L^H*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
+* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1)
+*
+ ELSE
+*
+* Loop forward applying the L-transformations.
+*
+ K = 1
+ 100 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 120
+*
+* 1 x 1 pivot block
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.LT.N ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate', N-K, NRHS, CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.LT.N-1 ) THEN
+*
+* Swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the second of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformation
+*
+ CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE,
+ $ B( K+1, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+*
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Conjugate', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE,
+ $ B( K, 1 ), LDB )
+ CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D21 = A( K+1, K )
+ D12 = DCONJG( D21 )
+ DO 110 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 110 CONTINUE
+ END IF
+ K = K + 2
+ END IF
+ GO TO 100
+ 120 CONTINUE
+ END IF
+*
+ END IF
+ RETURN
+*
+* End of ZLAVHE_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zlavsy.f b/lapack-netlib/TESTING/LIN/zlavsy.f
index 6005e7058..2f8ecd88f 100644
--- a/lapack-netlib/TESTING/LIN/zlavsy.f
+++ b/lapack-netlib/TESTING/LIN/zlavsy.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
* LDB, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
@@ -19,14 +19,14 @@
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> ZLAVSY performs one of the matrix-vector operations
+*> ZLAVSY performs one of the matrix-vector operations
*> x := A*x or x := A'*x,
*> where x is an N element vector and A is one of the factors
*> from the block U*D*U' or L*D*L' factorization computed by ZSYTRF.
@@ -83,6 +83,7 @@
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZSYTRF.
+*> Stored as a 2-D triangular matrix.
*> \endverbatim
*>
*> \param[in] LDA
@@ -95,7 +96,7 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D,
-*> as determined by ZSYTRF or ZHETRF.
+*> as determined by ZSYTRF.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
@@ -139,12 +140,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -152,10 +153,10 @@
SUBROUTINE ZLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
diff --git a/lapack-netlib/TESTING/LIN/zlavsy_rook.f b/lapack-netlib/TESTING/LIN/zlavsy_rook.f
new file mode 100644
index 000000000..ed62f8f17
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zlavsy_rook.f
@@ -0,0 +1,581 @@
+*> \brief \b ZLAVSY_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
+* LDB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIAG, TRANS, UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAVSY_ROOK performs one of the matrix-vector operations
+*> x := A*x or x := A'*x,
+*> where x is an N element vector and A is one of the factors
+*> from the block U*D*U' or L*D*L' factorization computed by ZSYTRF_ROOK.
+*>
+*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
+*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the factor stored in A is upper or lower
+*> triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation to be performed:
+*> = 'N': x := A*x
+*> = 'T': x := A'*x
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the diagonal blocks are unit
+*> matrices. If the diagonal blocks are assumed to be unit,
+*> then A = U or A = L, otherwise A = U*D or A = L*D.
+*> = 'U': Diagonal blocks are assumed to be unit matrices.
+*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of vectors
+*> x to be multiplied by A. NRHS >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The block diagonal matrix D and the multipliers used to
+*> obtain the factor U or L as computed by ZSYTRF_ROOK.
+*> Stored as a 2-D triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by ZSYTRF_ROOK.
+*>
+*> If UPLO = 'U':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k-1 and -IPIV(k-1) were inerchaged,
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*>
+*> If UPLO = 'L':
+*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
+*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
+*> (If IPIV( k ) = k, no interchange was done).
+*>
+*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
+*> columns k and -IPIV(k) were interchanged and rows and
+*> columns k+1 and -IPIV(k+1) were inerchaged,
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, B contains NRHS vectors of length N.
+*> On exit, B is overwritten with the product A * B.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV,
+ $ B, LDB, INFO )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 CONE
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+ INTEGER J, K, KP
+ COMPLEX*16 D11, D12, D21, D22, T1, T2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZGEMV, ZGERU, ZSCAL, ZSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZLAVSY_ROOK ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ NOUNIT = LSAME( DIAG, 'N' )
+*------------------------------------------
+*
+* Compute B := A * B (No transpose)
+*
+*------------------------------------------
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := U*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop forward applying the transformations.
+*
+ K = 1
+ 10 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 30
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block
+*
+* Multiply by the diagonal element if forming U * D.
+*
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformation.
+*
+ CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K + 1
+ ELSE
+*
+* 2 x 2 pivot block
+*
+* Multiply by the diagonal block if forming U * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D12 = A( K, K+1 )
+ D21 = D12
+ DO 20 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 20 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(U(K)) if K > 1.
+*
+ IF( K.GT.1 ) THEN
+*
+* Apply the transformations.
+*
+ CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+ CALL ZGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the first of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K + 2
+ END IF
+ GO TO 10
+ 30 CONTINUE
+*
+* Compute B := L*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
+*
+ ELSE
+*
+* Loop backward applying the transformations to B.
+*
+ K = N
+ 40 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+* Test the pivot index. If greater than zero, a 1 x 1
+* pivot was used, otherwise a 2 x 2 pivot was used.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 pivot block:
+*
+* Multiply by the diagonal element if forming L * D.
+*
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+ KP = IPIV( K )
+*
+* Apply the transformation.
+*
+ CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ K = K - 1
+*
+ ELSE
+*
+* 2 x 2 pivot block:
+*
+* Multiply by the diagonal block if forming L * D.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D21 = A( K, K-1 )
+ D12 = D21
+ DO 50 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 50 CONTINUE
+ END IF
+*
+* Multiply by P(K) * inv(L(K)) if K < N.
+*
+ IF( K.NE.N ) THEN
+*
+* Apply the transformation.
+*
+ CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1,
+ $ B( K, 1 ), LDB, B( K+1, 1 ), LDB )
+ CALL ZGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1,
+ $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
+*
+* Interchange if a permutation was applied at the
+* K-th step of the factorization.
+*
+* Swap the second of pair with IMAXth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* NOW swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+ END IF
+ K = K - 2
+ END IF
+ GO TO 40
+ 60 CONTINUE
+ END IF
+*----------------------------------------
+*
+* Compute B := A' * B (transpose)
+*
+*----------------------------------------
+ ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+* Form B := U'*B
+* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
+* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Loop backward applying the transformations.
+*
+ K = N
+ 70 CONTINUE
+ IF( K.LT.1 )
+ $ GO TO 90
+*
+* 1 x 1 pivot block.
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.GT.1 ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL ZGEMV( 'Transpose', K-1, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.GT.2 ) THEN
+*
+* Swap the second of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the first of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K-1 ) )
+ IF( KP.NE.K-1 )
+ $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformations
+*
+ CALL ZGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K ), 1, CONE, B( K, 1 ), LDB )
+ CALL ZGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB,
+ $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K-1, K-1 )
+ D22 = A( K, K )
+ D12 = A( K-1, K )
+ D21 = D12
+ DO 80 J = 1, NRHS
+ T1 = B( K-1, J )
+ T2 = B( K, J )
+ B( K-1, J ) = D11*T1 + D12*T2
+ B( K, J ) = D21*T1 + D22*T2
+ 80 CONTINUE
+ END IF
+ K = K - 2
+ END IF
+ GO TO 70
+ 90 CONTINUE
+*
+* Form B := L'*B
+* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
+* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
+*
+ ELSE
+*
+* Loop forward applying the L-transformations.
+*
+ K = 1
+ 100 CONTINUE
+ IF( K.GT.N )
+ $ GO TO 120
+*
+* 1 x 1 pivot block
+*
+ IF( IPIV( K ).GT.0 ) THEN
+ IF( K.LT.N ) THEN
+*
+* Interchange if P(K) != I.
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Apply the transformation
+*
+ CALL ZGEMV( 'Transpose', N-K, NRHS, CONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
+ END IF
+ IF( NOUNIT )
+ $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+*
+* 2 x 2 pivot block.
+*
+ ELSE
+ IF( K.LT.N-1 ) THEN
+*
+* Swap the first of pair with Pth
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K )
+ $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Now swap the second of pair with IMAX(r)th
+*
+ KP = ABS( IPIV( K+1 ) )
+ IF( KP.NE.K+1 )
+ $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
+ $ LDB )
+*
+* Apply the transformation
+*
+ CALL ZGEMV( 'Transpose', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE,
+ $ B( K+1, 1 ), LDB )
+ CALL ZGEMV( 'Transpose', N-K-1, NRHS, CONE,
+ $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE,
+ $ B( K, 1 ), LDB )
+ END IF
+*
+* Multiply by the diagonal block if non-unit.
+*
+ IF( NOUNIT ) THEN
+ D11 = A( K, K )
+ D22 = A( K+1, K+1 )
+ D21 = A( K+1, K )
+ D12 = D21
+ DO 110 J = 1, NRHS
+ T1 = B( K, J )
+ T2 = B( K+1, J )
+ B( K, J ) = D11*T1 + D12*T2
+ B( K+1, J ) = D21*T1 + D22*T2
+ 110 CONTINUE
+ END IF
+ K = K + 2
+ END IF
+ GO TO 100
+ 120 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of ZLAVSY_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/LIN/zsyt01.f b/lapack-netlib/TESTING/LIN/zsyt01.f
index 9b3d44ba3..4ec551180 100644
--- a/lapack-netlib/TESTING/LIN/zsyt01.f
+++ b/lapack-netlib/TESTING/LIN/zsyt01.f
@@ -2,15 +2,15 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
* RWORK, RESID )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDAFAC, LDC, N
@@ -21,7 +21,7 @@
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -112,12 +112,12 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
-*> \date November 2011
+*> \date November 2013
*
*> \ingroup complex16_lin
*
@@ -125,10 +125,10 @@
SUBROUTINE ZSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
-* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK test routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2011
+* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
diff --git a/lapack-netlib/TESTING/LIN/zsyt01_rook.f b/lapack-netlib/TESTING/LIN/zsyt01_rook.f
new file mode 100644
index 000000000..4e7ea24aa
--- /dev/null
+++ b/lapack-netlib/TESTING/LIN/zsyt01_rook.f
@@ -0,0 +1,227 @@
+*> \brief \b ZSYT01_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
+* RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYT01_ROOK reconstructs a complex symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix, EPS is the machine epsilon,
+*> L' is the transpose of L, and U' is the transpose of U.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> complex symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The original complex symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
+*> The factored form of the matrix A. AFAC contains the block
+*> diagonal matrix D and the multipliers used to obtain the
+*> factor L or U from the block L*D*L' or U*D*U' factorization
+*> as computed by ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC. LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from ZSYTRF_ROOK.
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is DOUBLE PRECISION
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ COMPLEX*16 CZERO, CONE
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
+ $ CONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ DOUBLE PRECISION ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, ZLANSY
+ EXTERNAL LSAME, DLAMCH, ZLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLASET, ZLAVSY_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* Determine EPS and the norm of A.
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Initialize C to the identity matrix.
+*
+ CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* Call ZLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL ZLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Call ZLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL ZLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = ZLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
+ END IF
+*
+ RETURN
+*
+* End of ZSYT01_ROOK
+*
+ END
diff --git a/lapack-netlib/TESTING/csd.in b/lapack-netlib/TESTING/csd.in
index b146d3954..a0a2e5450 100644
--- a/lapack-netlib/TESTING/csd.in
+++ b/lapack-netlib/TESTING/csd.in
@@ -3,7 +3,7 @@ CSD: Data file for testing CS decomposition routines
0 10 10 10 10 21 24 30 22 32 55 Values of M (row and column dimension of unitary matrix)
0 4 4 0 10 9 10 20 12 12 40 Values of P (row dimension of top-left block)
0 0 10 4 4 15 12 8 20 8 20 Values of Q (column dimension of top-left block)
-10.0 Threshold value of test ratio
+30.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
-CSD 3 List types on next line if 0 < NTYPES < 3
+CSD 4 List types on next line if 0 < NTYPES < 3
diff --git a/lapack-netlib/TESTING/ctest.in b/lapack-netlib/TESTING/ctest.in
index de44a09c5..e46549310 100644
--- a/lapack-netlib/TESTING/ctest.in
+++ b/lapack-netlib/TESTING/ctest.in
@@ -23,8 +23,10 @@ CPP 9 List types on next line if 0 < NTYPES < 9
CPB 8 List types on next line if 0 < NTYPES < 8
CPT 12 List types on next line if 0 < NTYPES < 12
CHE 10 List types on next line if 0 < NTYPES < 10
+CHR 10 List types on next line if 0 < NTYPES < 10
CHP 10 List types on next line if 0 < NTYPES < 10
CSY 11 List types on next line if 0 < NTYPES < 11
+CSR 11 List types on next line if 0 < NTYPES < 11
CSP 11 List types on next line if 0 < NTYPES < 11
CTR 18 List types on next line if 0 < NTYPES < 18
CTP 18 List types on next line if 0 < NTYPES < 18
diff --git a/lapack-netlib/TESTING/dtest.in b/lapack-netlib/TESTING/dtest.in
index 5925174aa..467a01c80 100644
--- a/lapack-netlib/TESTING/dtest.in
+++ b/lapack-netlib/TESTING/dtest.in
@@ -23,6 +23,7 @@ DPP 9 List types on next line if 0 < NTYPES < 9
DPB 8 List types on next line if 0 < NTYPES < 8
DPT 12 List types on next line if 0 < NTYPES < 12
DSY 10 List types on next line if 0 < NTYPES < 10
+DSR 10 List types on next line if 0 < NTYPES < 10
DSP 10 List types on next line if 0 < NTYPES < 10
DTR 18 List types on next line if 0 < NTYPES < 18
DTP 18 List types on next line if 0 < NTYPES < 18
diff --git a/lapack-netlib/TESTING/stest.in b/lapack-netlib/TESTING/stest.in
index 155a50f7d..bd7f884ba 100644
--- a/lapack-netlib/TESTING/stest.in
+++ b/lapack-netlib/TESTING/stest.in
@@ -23,6 +23,7 @@ SPP 9 List types on next line if 0 < NTYPES < 9
SPB 8 List types on next line if 0 < NTYPES < 8
SPT 12 List types on next line if 0 < NTYPES < 12
SSY 10 List types on next line if 0 < NTYPES < 10
+SSR 10 List types on next line if 0 < NTYPES < 10
SSP 10 List types on next line if 0 < NTYPES < 10
STR 18 List types on next line if 0 < NTYPES < 18
STP 18 List types on next line if 0 < NTYPES < 18
diff --git a/lapack-netlib/TESTING/ztest.in b/lapack-netlib/TESTING/ztest.in
index a9d9daea4..106035101 100644
--- a/lapack-netlib/TESTING/ztest.in
+++ b/lapack-netlib/TESTING/ztest.in
@@ -23,8 +23,10 @@ ZPP 9 List types on next line if 0 < NTYPES < 9
ZPB 8 List types on next line if 0 < NTYPES < 8
ZPT 12 List types on next line if 0 < NTYPES < 12
ZHE 10 List types on next line if 0 < NTYPES < 10
+ZHR 10 List types on next line if 0 < NTYPES < 10
ZHP 10 List types on next line if 0 < NTYPES < 10
ZSY 11 List types on next line if 0 < NTYPES < 11
+ZSR 11 List types on next line if 0 < NTYPES < 11
ZSP 11 List types on next line if 0 < NTYPES < 11
ZTR 18 List types on next line if 0 < NTYPES < 18
ZTP 18 List types on next line if 0 < NTYPES < 18
diff --git a/lapack-netlib/lapack_testing.py b/lapack-netlib/lapack_testing.py
index 3bd94621b..d0b9aaac5 100755
--- a/lapack-netlib/lapack_testing.py
+++ b/lapack-netlib/lapack_testing.py
@@ -139,7 +139,7 @@ def run_summary_test( f, cmdline, short_summary):
if (short_summary==0): print line,
whereisout= words_in_line.index("out")
nb_test_fail+=int(words_in_line[whereisout-1])
- if (line.find("illegal")!=-1):
+ if ((line.find("illegal")!=-1) or (line.find("Illegal")!=-1)):
if (short_summary==0):print line,
nb_test_illegal+=1
if (line.find(" INFO")!=-1):
diff --git a/lapack-netlib/lapacke/example/CMakeLists.txt b/lapack-netlib/lapacke/example/CMakeLists.txt
index 9e00c94ef..a1c590965 100644
--- a/lapack-netlib/lapacke/example/CMakeLists.txt
+++ b/lapack-netlib/lapacke/example/CMakeLists.txt
@@ -1,8 +1,14 @@
-add_executable(xexample_DGESV_rowmajor example_DGESV_rowmajor.c)
-add_executable(xexample_ZGESV_rowmajor example_ZGESV_rowmajor.c)
+add_executable(xexample_DGESV_rowmajor example_DGESV_rowmajor.c lapacke_example_aux.c lapacke_example_aux.h)
+add_executable(xexample_DGESV_colmajor example_DGESV_colmajor.c lapacke_example_aux.c lapacke_example_aux.h)
+add_executable(xexample_DGELS_rowmajor example_DGELS_rowmajor.c lapacke_example_aux.c lapacke_example_aux.h)
+add_executable(xexample_DGELS_colmajor example_DGELS_colmajor.c lapacke_example_aux.c lapacke_example_aux.h)
target_link_libraries(xexample_DGESV_rowmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
-target_link_libraries(xexample_ZGESV_rowmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xexample_DGESV_colmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xexample_DGELS_rowmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xexample_DGELS_colmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
add_test(example_DGESV_rowmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGESV_rowmajor)
-add_test(example_ZGESV_rowmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_ZGESV_rowmajor)
+add_test(example_DGESV_colmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGESV_colmajor)
+add_test(example_DGELS_rowmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGELS_rowmajor)
+add_test(example_DGELS_colmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGELS_colmajor)
diff --git a/lapack-netlib/lapacke/example/Makefile b/lapack-netlib/lapacke/example/Makefile
index a2ffaefe0..52c46707f 100644
--- a/lapack-netlib/lapacke/example/Makefile
+++ b/lapack-netlib/lapacke/example/Makefile
@@ -1,19 +1,35 @@
include ../../make.inc
-all: xexample_DGESV_rowmajor xexample_ZGESV_rowmajor
+all: xexample_DGESV_rowmajor \
+ xexample_DGESV_colmajor \
+ xexample_DGELS_rowmajor \
+ xexample_DGELS_colmajor
-xexample_DGESV_rowmajor: example_DGESV_rowmajor.o ../../$(LAPACKLIB) ../../$(LAPACKELIB)
- $(LOADER) $(LOADOPTS) example_DGESV_rowmajor.o \
- ../../$(LAPACKELIB) $(CEXTRALIB) -o $@
+LIBRAIRIES= ../../$(LAPACKELIB) ../../$(LAPACKLIB) $(BLASLIB)
+
+# Double Precision Examples
+xexample_DGESV_rowmajor: example_DGESV_rowmajor.o lapacke_example_aux.o $(LIBRAIRIES)
+ $(LOADER) $(LOADOPTS) example_DGESV_rowmajor.o lapacke_example_aux.o \
+ $(LIBRAIRIES) -o $@
+ ./$@
+
+xexample_DGESV_colmajor: example_DGESV_colmajor.o lapacke_example_aux.o $(LIBRAIRIES)
+ $(LOADER) $(LOADOPTS) example_DGESV_colmajor.o lapacke_example_aux.o \
+ $(LIBRAIRIES) -o $@
+ ./$@
+
+xexample_DGELS_rowmajor: example_DGELS_rowmajor.o lapacke_example_aux.o $(LIBRAIRIES)
+ $(LOADER) $(LOADOPTS) example_DGELS_rowmajor.o lapacke_example_aux.o \
+ $(LIBRAIRIES) -o $@
./$@
-xexample_ZGESV_rowmajor: example_ZGESV_rowmajor.o ../../$(LAPACKLIB) ../../$(LAPACKELIB)
- $(LOADER) $(LOADOPTS) example_ZGESV_rowmajor.o \
- ../../$(LAPACKELIB) $(CEXTRALIB) -o $@
+xexample_DGELS_colmajor: example_DGELS_colmajor.o lapacke_example_aux.o $(LIBRAIRIES)
+ $(LOADER) $(LOADOPTS) example_DGELS_colmajor.o lapacke_example_aux.o \
+ $(LIBRAIRIES) -o $@
./$@
.c.o:
- $(CC) -c $(CFLAGS) -I ../include -o $@ $<
+ $(CC) -c $(CFLAGS) -I. -I ../include -o $@ $<
clean:
- rm -f *.o xexample_DGESV_rowmajor xexample_ZGESV_rowmajor
\ No newline at end of file
+ rm -f *.o x*
diff --git a/lapack-netlib/lapacke/example/example_DGELS_colmajor.c b/lapack-netlib/lapacke/example/example_DGELS_colmajor.c
new file mode 100644
index 000000000..b5e0bbbb1
--- /dev/null
+++ b/lapack-netlib/lapacke/example/example_DGELS_colmajor.c
@@ -0,0 +1,96 @@
+/*
+ LAPACKE Example : Calling DGELS using col-major order
+ =====================================================
+
+ The program computes the solution to the system of linear
+ equations with a square matrix A and multiple
+ right-hand sides B, where A is the coefficient matrix
+ and b is the right-hand side matrix:
+
+ Description
+ ===========
+
+ In this example, we wish solve the least squares problem min_x || B - Ax ||
+ for two right-hand sides using the LAPACK routine DGELS. For input we will
+ use the 5-by-3 matrix
+
+ ( 1 1 1 )
+ ( 2 3 4 )
+ A = ( 3 5 2 )
+ ( 4 2 5 )
+ ( 5 4 3 )
+ and the 5-by-2 matrix
+
+ ( -10 -3 )
+ ( 12 14 )
+ B = ( 14 12 )
+ ( 16 16 )
+ ( 18 16 )
+ We will first store the input matrix as a static C two-dimensional array,
+ which is stored in col-major order, and let LAPACKE handle the work space
+ array allocation. The LAPACK base name for this function is gels, and we
+ will use double precision (d), so the LAPACKE function name is LAPACKE_dgels.
+
+ lda=5 and ldb=5. The output for each right hand side is stored in b as
+ consecutive vectors of length 3. The correct answer for this problem is
+ the 3-by-2 matrix
+
+ ( 2 1 )
+ ( 1 1 )
+ ( 1 2 )
+
+ A complete C program for this example is given below. Note that when the arrays
+ are passed to the LAPACK routine, they must be dereferenced, since LAPACK is
+ expecting arrays of type double *, not double **.
+
+
+ LAPACKE Interface
+ =================
+
+ LAPACKE_dgels (col-major, high-level) Example Program Results
+
+ -- LAPACKE Example routine (version 3.5.0) --
+ -- LAPACK is a software package provided by Univ. of Tennessee, --
+ -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+ February 2012
+
+*/
+/* Calling DGELS using col-major order */
+
+/* Includes */
+#include
+#include
+#include "lapacke_example_aux.h"
+
+/* Main program */
+int main (int argc, const char * argv[])
+{
+ /* Locals */
+ double A[5][3] = {1,2,3,4,5,1,3,5,2,4,1,4,2,5,3};
+ double b[5][2] = {-10,12,14,16,18,-3,14,12,16,16};
+ lapack_int info,m,n,lda,ldb,nrhs;
+ int i,j;
+
+ /* Initialization */
+ m = 5;
+ n = 3;
+ nrhs = 2;
+ lda = 5;
+ ldb = 5;
+
+ /* Print Entry Matrix */
+ print_matrix_colmajor( "Entry Matrix A", m, n, *A, lda );
+ /* Print Right Rand Side */
+ print_matrix_colmajor( "Right Hand Side b", n, nrhs, *b, ldb );
+ printf( "\n" );
+
+ /* Executable statements */
+ printf( "LAPACKE_dgels (col-major, high-level) Example Program Results\n" );
+ /* Solve least squares problem*/
+ info = LAPACKE_dgels(LAPACK_COL_MAJOR,'N',m,n,nrhs,*A,lda,*b,ldb);
+
+ /* Print Solution */
+ print_matrix_colmajor( "Solution", n, nrhs, *b, ldb );
+ printf( "\n" );
+ exit( 0 );
+} /* End of LAPACKE_dgels Example */
diff --git a/lapack-netlib/lapacke/example/example_DGELS_rowmajor.c b/lapack-netlib/lapacke/example/example_DGELS_rowmajor.c
new file mode 100644
index 000000000..331aa2f8d
--- /dev/null
+++ b/lapack-netlib/lapacke/example/example_DGELS_rowmajor.c
@@ -0,0 +1,96 @@
+/*
+ LAPACKE Example : Calling DGELS using row-major order
+ =====================================================
+
+ The program computes the solution to the system of linear
+ equations with a square matrix A and multiple
+ right-hand sides B, where A is the coefficient matrix
+ and b is the right-hand side matrix:
+
+ Description
+ ===========
+
+ In this example, we wish solve the least squares problem min_x || B - Ax ||
+ for two right-hand sides using the LAPACK routine DGELS. For input we will
+ use the 5-by-3 matrix
+
+ ( 1 1 1 )
+ ( 2 3 4 )
+ A = ( 3 5 2 )
+ ( 4 2 5 )
+ ( 5 4 3 )
+ and the 5-by-2 matrix
+
+ ( -10 -3 )
+ ( 12 14 )
+ B = ( 14 12 )
+ ( 16 16 )
+ ( 18 16 )
+ We will first store the input matrix as a static C two-dimensional array,
+ which is stored in row-major order, and let LAPACKE handle the work space
+ array allocation. The LAPACK base name for this function is gels, and we
+ will use double precision (d), so the LAPACKE function name is LAPACKE_dgels.
+
+ thus lda=3 and ldb=2. The output for each right hand side is stored in b as
+ consecutive vectors of length 3. The correct answer for this problem is
+ the 3-by-2 matrix
+
+ ( 2 1 )
+ ( 1 1 )
+ ( 1 2 )
+
+ A complete C program for this example is given below. Note that when the arrays
+ are passed to the LAPACK routine, they must be dereferenced, since LAPACK is
+ expecting arrays of type double *, not double **.
+
+
+ LAPACKE Interface
+ =================
+
+ LAPACKE_dgels (row-major, high-level) Example Program Results
+
+ -- LAPACKE Example routine (version 3.5.0) --
+ -- LAPACK is a software package provided by Univ. of Tennessee, --
+ -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+ February 2012
+
+*/
+/* Calling DGELS using row-major order */
+
+/* Includes */
+#include
+#include
+#include "lapacke_example_aux.h"
+
+/* Main program */
+int main (int argc, const char * argv[])
+{
+ /* Locals */
+ double A[5][3] = {1,1,1,2,3,4,3,5,2,4,2,5,5,4,3};
+ double b[5][2] = {-10,-3,12,14,14,12,16,16,18,16};
+ lapack_int info,m,n,lda,ldb,nrhs;
+ int i,j;
+
+ /* Initialization */
+ m = 5;
+ n = 3;
+ nrhs = 2;
+ lda = 3;
+ ldb = 2;
+
+ /* Print Entry Matrix */
+ print_matrix_rowmajor( "Entry Matrix A", m, n, *A, lda );
+ /* Print Right Rand Side */
+ print_matrix_rowmajor( "Right Hand Side b", n, nrhs, *b, ldb );
+ printf( "\n" );
+
+ /* Executable statements */
+ printf( "LAPACKE_dgels (row-major, high-level) Example Program Results\n" );
+ /* Solve least squares problem*/
+ info = LAPACKE_dgels(LAPACK_ROW_MAJOR,'N',m,n,nrhs,*A,lda,*b,ldb);
+
+ /* Print Solution */
+ print_matrix_rowmajor( "Solution", n, nrhs, *b, ldb );
+ printf( "\n" );
+ exit( 0 );
+} /* End of LAPACKE_dgels Example */
diff --git a/lapack-netlib/lapacke/example/example_DGESV_colmajor.c b/lapack-netlib/lapacke/example/example_DGESV_colmajor.c
new file mode 100644
index 000000000..be0432c0c
--- /dev/null
+++ b/lapack-netlib/lapacke/example/example_DGESV_colmajor.c
@@ -0,0 +1,111 @@
+/*
+ LAPACKE_dgesv Example
+ =====================
+
+ The program computes the solution to the system of linear
+ equations with a square matrix A and multiple
+ right-hand sides B, where A is the coefficient matrix
+ and b is the right-hand side matrix:
+
+ Description
+ ===========
+
+ The routine solves for X the system of linear equations A*X = B,
+ where A is an n-by-n matrix, the columns of matrix B are individual
+ right-hand sides, and the columns of X are the corresponding
+ solutions.
+
+ The LU decomposition with partial pivoting and row interchanges is
+ used to factor A as A = P*L*U, where P is a permutation matrix, L
+ is unit lower triangular, and U is upper triangular. The factored
+ form of A is then used to solve the system of equations A*X = B.
+
+ LAPACKE Interface
+ =================
+
+ LAPACKE_dgesv (col-major, high-level) Example Program Results
+
+ -- LAPACKE Example routine (version 3.5.0) --
+ -- LAPACK is a software package provided by Univ. of Tennessee, --
+ -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+ February 2012
+
+*/
+/* Includes */
+#include
+#include
+#include
+#include "lapacke.h"
+#include "lapacke_example_aux.h"
+
+/* Main program */
+int main(int argc, char **argv) {
+
+ /* Locals */
+ lapack_int n, nrhs, lda, ldb, info;
+ int i, j;
+ double normr, normb;
+ /* Local arrays */
+ double *A, *b, *Acopy, *bcopy;
+ lapack_int *ipiv;
+
+ /* Default Value */
+ n = 5; nrhs = 1;
+
+ /* Arguments */
+ for( i = 1; i < argc; i++ ) {
+ if( strcmp( argv[i], "-n" ) == 0 ) {
+ n = atoi(argv[i+1]);
+ i++;
+ }
+ if( strcmp( argv[i], "-nrhs" ) == 0 ) {
+ nrhs = atoi(argv[i+1]);
+ i++;
+ }
+ }
+
+ /* Initialization */
+ lda=n, ldb=n;
+ A = (double *)malloc(n*n*sizeof(double)) ;
+ if (A==NULL){ printf("error of memory allocation\n"); exit(0); }
+ b = (double *)malloc(n*nrhs*sizeof(double)) ;
+ if (b==NULL){ printf("error of memory allocation\n"); exit(0); }
+ ipiv = (lapack_int *)malloc(n*sizeof(lapack_int)) ;
+ if (ipiv==NULL){ printf("error of memory allocation\n"); exit(0); }
+
+ for( i = 0; i < n; i++ ) {
+ for( j = 0; j < n; j++ ) A[i+j*lda] = ((double) rand()) / ((double) RAND_MAX) - 0.5;
+ }
+
+ for(i=0;i 0 ) {
+ printf( "The diagonal element of the triangular factor of A,\n" );
+ printf( "U(%i,%i) is zero, so that A is singular;\n", info, info );
+ printf( "the solution could not be computed.\n" );
+ exit( 1 );
+ }
+ if (info <0) exit( 1 );
+ /* Print solution */
+ print_matrix_colmajor( "Solution", n, nrhs, b, ldb );
+ /* Print details of LU factorization */
+ print_matrix_colmajor( "Details of LU factorization", n, n, A, lda );
+ /* Print pivot indices */
+ print_vector( "Pivot indices", n, ipiv );
+ exit( 0 );
+} /* End of LAPACKE_dgesv Example */
+
diff --git a/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c b/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c
index a932e8093..4406733ac 100644
--- a/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c
+++ b/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c
@@ -1,44 +1,14 @@
-/*******************************************************************************
-* Copyright (C) 2009-2011 Intel Corporation. All Rights Reserved.
-* The information and material ("Material") provided below is owned by Intel
-* Corporation or its suppliers or licensors, and title to such Material remains
-* with Intel Corporation or its suppliers or licensors. The Material contains
-* proprietary information of Intel or its suppliers and licensors. The Material
-* is protected by worldwide copyright laws and treaty provisions. No part of
-* the Material may be copied, reproduced, published, uploaded, posted,
-* transmitted, or distributed in any way without Intel's prior express written
-* permission. No license under any patent, copyright or other intellectual
-* property rights in the Material is granted to or conferred upon you, either
-* expressly, by implication, inducement, estoppel or otherwise. Any license
-* under such intellectual property rights must be express and approved by Intel
-* in writing.
-*
-********************************************************************************
-*/
/*
- LAPACKE_dgesv Example.
- ======================
+ LAPACKE_dgesv Example
+ =====================
The program computes the solution to the system of linear
equations with a square matrix A and multiple
- right-hand sides B, where A is the coefficient matrix:
-
- 6.80 -6.05 -0.45 8.32 -9.67
- -2.11 -3.30 2.58 2.71 -5.14
- 5.66 5.36 -2.70 4.35 -7.26
- 5.97 -4.44 0.27 -7.17 6.08
- 8.23 1.08 9.04 2.14 -6.87
-
- and B is the right-hand side matrix:
-
- 4.02 -1.56 9.81
- 6.19 4.00 -4.09
- -8.22 -8.67 -4.57
- -7.57 1.75 -8.61
- -3.03 2.86 8.99
-
- Description.
- ============
+ right-hand sides B, where A is the coefficient matrix
+ and b is the right-hand side matrix:
+
+ Description
+ ===========
The routine solves for X the system of linear equations A*X = B,
where A is an n-by-n matrix, the columns of matrix B are individual
@@ -50,71 +20,74 @@
is unit lower triangular, and U is upper triangular. The factored
form of A is then used to solve the system of equations A*X = B.
- Example Program Results.
- ========================
-
- LAPACKE_dgesv (row-major, high-level) Example Program Results
+ LAPACKE Interface
+ =================
- Solution
- -0.80 -0.39 0.96
- -0.70 -0.55 0.22
- 0.59 0.84 1.90
- 1.32 -0.10 5.36
- 0.57 0.11 4.04
+ LAPACKE_dgesv (row-major, high-level) Example Program Results
- Details of LU factorization
- 8.23 1.08 9.04 2.14 -6.87
- 0.83 -6.94 -7.92 6.55 -3.99
- 0.69 -0.67 -14.18 7.24 -5.19
- 0.73 0.75 0.02 -13.82 14.19
- -0.26 0.44 -0.59 -0.34 -3.43
+ -- LAPACKE Example routine (version 3.5.0) --
+ -- LAPACK is a software package provided by Univ. of Tennessee, --
+ -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+ February 2012
- Pivot indices
- 5 5 3 4 5
*/
#include
#include
-#include "lapacke.h"
-
-/* Auxiliary routines prototypes */
-extern void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda );
-extern void print_int_vector( char* desc, lapack_int n, lapack_int* a );
-
-/* Parameters */
-#define N 5
-#define NRHS 3
-#define LDA N
-#define LDB NRHS
+#include
+#include
+#include "lapacke_example_aux.h"
/* Main program */
-int main() {
+int main(int argc, char **argv) {
+
/* Locals */
- lapack_int n = N, nrhs = NRHS, lda = LDA, ldb = LDB, info;
+ lapack_int n, nrhs, lda, ldb, info;
+ int i, j;
+ double normr, normb;
/* Local arrays */
- lapack_int ipiv[N];
- double a[LDA*N] = {
- 6.80, -6.05, -0.45, 8.32, -9.67,
- -2.11, -3.30, 2.58, 2.71, -5.14,
- 5.66, 5.36, -2.70, 4.35, -7.26,
- 5.97, -4.44, 0.27, -7.17, 6.08,
- 8.23, 1.08, 9.04, 2.14, -6.87
- };
- double b[LDB*N] = {
- 4.02, -1.56, 9.81,
- 6.19, 4.00, -4.09,
- -8.22, -8.67, -4.57,
- -7.57, 1.75, -8.61,
- -3.03, 2.86, 8.99
- };
+ double *A, *b, *Acopy, *bcopy;
+ lapack_int *ipiv;
+
+ /* Default Value */
+ n = 5; nrhs = 1;
+
+ /* Arguments */
+ for( i = 1; i < argc; i++ ) {
+ if( strcmp( argv[i], "-n" ) == 0 ) {
+ n = atoi(argv[i+1]);
+ i++;
+ }
+ if( strcmp( argv[i], "-nrhs" ) == 0 ) {
+ nrhs = atoi(argv[i+1]);
+ i++;
+ }
+ }
+
+ /* Initialization */
+ lda=n, ldb=nrhs;
+ A = (double *)malloc(n*n*sizeof(double)) ;
+ if (A==NULL){ printf("error of memory allocation\n"); exit(0); }
+ b = (double *)malloc(n*nrhs*sizeof(double)) ;
+ if (b==NULL){ printf("error of memory allocation\n"); exit(0); }
+ ipiv = (lapack_int *)malloc(n*sizeof(lapack_int)) ;
+ if (ipiv==NULL){ printf("error of memory allocation\n"); exit(0); }
+
+ for( i = 0; i < n; i++ ) {
+ for( j = 0; j < n; j++ ) A[i*lda+j] = ((double) rand()) / ((double) RAND_MAX) - 0.5;
+ }
+
+ for(i=0;i 0 ) {
@@ -123,29 +96,13 @@ int main() {
printf( "the solution could not be computed.\n" );
exit( 1 );
}
+ if (info <0) exit( 1 );
/* Print solution */
- print_matrix( "Solution", n, nrhs, b, ldb );
+ print_matrix_rowmajor( "Solution", n, nrhs, b, ldb );
/* Print details of LU factorization */
- print_matrix( "Details of LU factorization", n, n, a, lda );
+ print_matrix_rowmajor( "Details of LU factorization", n, n, A, lda );
/* Print pivot indices */
- print_int_vector( "Pivot indices", n, ipiv );
+ print_vector( "Pivot indices", n, ipiv );
exit( 0 );
} /* End of LAPACKE_dgesv Example */
-/* Auxiliary routine: printing a matrix */
-void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ) {
- lapack_int i, j;
- printf( "\n %s\n", desc );
- for( i = 0; i < m; i++ ) {
- for( j = 0; j < n; j++ ) printf( " %6.2f", a[i*lda+j] );
- printf( "\n" );
- }
-}
-
-/* Auxiliary routine: printing a vector of integers */
-void print_int_vector( char* desc, lapack_int n, lapack_int* a ) {
- lapack_int j;
- printf( "\n %s\n", desc );
- for( j = 0; j < n; j++ ) printf( " %6i", a[j] );
- printf( "\n" );
-}
diff --git a/lapack-netlib/lapacke/example/example_user.c b/lapack-netlib/lapacke/example/example_user.c
new file mode 100644
index 000000000..c481fa705
--- /dev/null
+++ b/lapack-netlib/lapacke/example/example_user.c
@@ -0,0 +1,97 @@
+#include
+#include
+#include "lapacke.h"
+
+/* Auxiliary routines prototypes */
+extern void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda );
+extern void print_int_vector( char* desc, lapack_int n, lapack_int* a );
+
+/* Parameters */
+#define N 5
+#define NRHS 3
+#define LDA N
+#define LDB NRHS
+
+/* Main program */
+int main() {
+ /* Locals */
+ lapack_int n = N, nrhs = NRHS, lda = LDA, ldb = LDB, info;
+ /* Local arrays */
+ lapack_int ipiv[N];
+ double a[LDA*N] = {
+ 6.80, -6.05, -0.45, 8.32, -9.67,
+ -2.11, -3.30, 2.58, 2.71, -5.14,
+ 5.66, 5.36, -2.70, 4.35, -7.26,
+ 5.97, -4.44, 0.27, -7.17, 6.08,
+ 8.23, 1.08, 9.04, 2.14, -6.87
+ };
+ double b[LDB*N] = {
+ 4.02, -1.56, 9.81,
+ 6.19, 4.00, -4.09,
+ -8.22, -8.67, -4.57,
+ -7.57, 1.75, -8.61,
+ -3.03, 2.86, 8.99
+ };
+
+ double aNorm;
+ double rcond;
+ char ONE_NORM = '1';
+ lapack_int NROWS = n;
+ lapack_int NCOLS = n;
+ lapack_int LEADING_DIMENSION_A = n;
+
+ /* Print Entry Matrix */
+ print_matrix( "Entry Matrix A", n, n, a, lda );
+ /* Print Right Rand Side */
+ print_matrix( "Right Rand Side", n, nrhs, b, ldb );
+ printf( "\n" );
+ /* Executable statements */
+ printf( "LAPACKE_dgecon Example Program Results\n" );
+ aNorm = LAPACKE_dlange(LAPACK_ROW_MAJOR, ONE_NORM, NROWS, NCOLS, a, LEADING_DIMENSION_A);
+ info = LAPACKE_dgetrf(LAPACK_ROW_MAJOR, NROWS, NCOLS, a, LEADING_DIMENSION_A, ipiv);
+ info = LAPACKE_dgecon(LAPACK_ROW_MAJOR, ONE_NORM, n, a, LEADING_DIMENSION_A, aNorm, &rcond); // aNorm should be 35.019999999999996
+ double work[4*N];
+ int iwork[N];
+ //info = LAPACKE_dgecon_work(LAPACK_ROW_MAJOR, ONE_NORM, n, a, LEADING_DIMENSION_A, aNorm, &rcond, work, iwork); // aNorm should be 35.019999999999996
+ //dgecon_( &ONE_NORM, &n, a, &LEADING_DIMENSION_A, &aNorm, &rcond, work, iwork, &info );
+ /* Check for the exact singularity */
+ if (info == 0)
+ {
+ printf("LAPACKE_dgecon completed SUCCESSFULLY...\n");
+ }
+ else if ( info < 0 )
+ {
+ printf( "Element %d of A had an illegal value\n", -info );
+ exit( 1 );
+ }
+ else
+ {
+ printf( "Unrecognized value of INFO = %d\n", info );
+ exit( 1 );
+ }
+
+ /* Print solution */
+ printf("LAPACKE_dlange / One-norm of A = %lf\n", aNorm);
+ printf("LAPACKE_dgecon / RCOND of A = %f\n", rcond);
+ exit( 0 );
+} /* End of LAPACKE_dgesv Example */
+
+/* Auxiliary routine: printing a matrix */
+void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ) {
+ lapack_int i, j;
+ printf( "\n %s\n", desc );
+ for( i = 0; i < m; i++ ) {
+ for( j = 0; j < n; j++ ) printf( " %6.2f", a[i*lda+j] );
+ printf( "\n" );
+ }
+}
+
+/* Auxiliary routine: printing a vector of integers */
+void print_int_vector( char* desc, lapack_int n, lapack_int* a ) {
+ lapack_int j;
+ printf( "\n %s\n", desc );
+ for( j = 0; j < n; j++ ) printf( " %6i", a[j] );
+ printf( "\n" );
+}
+
+
diff --git a/lapack-netlib/lapacke/example/lapacke_example_aux.c b/lapack-netlib/lapacke/example/lapacke_example_aux.c
new file mode 100644
index 000000000..dfd60eb1d
--- /dev/null
+++ b/lapack-netlib/lapacke/example/lapacke_example_aux.c
@@ -0,0 +1,33 @@
+#include
+#include
+
+/* Auxiliary routine: printing a matrix */
+void print_matrix_rowmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ) {
+ lapack_int i, j;
+ printf( "\n %s\n", desc );
+
+ for( i = 0; i < m; i++ ) {
+ for( j = 0; j < n; j++ ) printf( " %6.2f", mat[i*ldm+j] );
+ printf( "\n" );
+ }
+}
+
+
+/* Auxiliary routine: printing a matrix */
+void print_matrix_colmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ) {
+ lapack_int i, j;
+ printf( "\n %s\n", desc );
+
+ for( i = 0; i < m; i++ ) {
+ for( j = 0; j < n; j++ ) printf( " %6.2f", mat[i+j*ldm] );
+ printf( "\n" );
+ }
+}
+
+/* Auxiliary routine: printing a vector of integers */
+void print_vector( char* desc, lapack_int n, lapack_int* vec ) {
+ lapack_int j;
+ printf( "\n %s\n", desc );
+ for( j = 0; j < n; j++ ) printf( " %6i", vec[j] );
+ printf( "\n" );
+}
diff --git a/lapack-netlib/lapacke/example/lapacke_example_aux.h b/lapack-netlib/lapacke/example/lapacke_example_aux.h
new file mode 100644
index 000000000..f83351152
--- /dev/null
+++ b/lapack-netlib/lapacke/example/lapacke_example_aux.h
@@ -0,0 +1,9 @@
+#ifndef _LAPACKE_EXAMPLE_AUX_
+#define _LAPACKE_EXAMPLE_AUX_
+
+
+void print_matrix_rowmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm );
+void print_matrix_colmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm );
+void print_vector( char* desc, lapack_int n, lapack_int* vec );
+
+#endif /* _LAPACKE_EXAMPLE_AUX_*/
diff --git a/lapack-netlib/lapacke/include/lapacke.h b/lapack-netlib/lapacke/include/lapacke.h
index e0367a25b..a31c10d6d 100644
--- a/lapack-netlib/lapacke/include/lapacke.h
+++ b/lapack-netlib/lapacke/include/lapacke.h
@@ -41,10 +41,6 @@
#include "lapacke_config.h"
#endif
-#ifdef __cplusplus
-extern "C" {
-#endif /* __cplusplus */
-
#include
#ifndef lapack_int
@@ -106,6 +102,10 @@ lapack_complex_double lapack_make_complex_double( double re, double im );
#endif
+#ifdef __cplusplus
+extern "C" {
+#endif /* __cplusplus */
+
#ifndef LAPACKE_malloc
#define LAPACKE_malloc( size ) malloc( size )
#endif
@@ -2102,6 +2102,17 @@ lapack_int LAPACKE_clacgv( lapack_int n, lapack_complex_float* x,
lapack_int LAPACKE_zlacgv( lapack_int n, lapack_complex_double* x,
lapack_int incx );
+lapack_int LAPACKE_slacn2( lapack_int n, float* v, float* x, lapack_int* isgn,
+ float* est, lapack_int* kase, lapack_int* isave );
+lapack_int LAPACKE_dlacn2( lapack_int n, double* v, double* x, lapack_int* isgn,
+ double* est, lapack_int* kase, lapack_int* isave );
+lapack_int LAPACKE_clacn2( lapack_int n, lapack_complex_float* v,
+ lapack_complex_float* x,
+ float* est, lapack_int* kase, lapack_int* isave );
+lapack_int LAPACKE_zlacn2( lapack_int n, lapack_complex_double* v,
+ lapack_complex_double* x,
+ double* est, lapack_int* kase, lapack_int* isave );
+
lapack_int LAPACKE_slacpy( int matrix_order, char uplo, lapack_int m,
lapack_int n, const float* a, lapack_int lda, float* b,
lapack_int ldb );
@@ -2117,6 +2128,13 @@ lapack_int LAPACKE_zlacpy( int matrix_order, char uplo, lapack_int m,
lapack_int lda, lapack_complex_double* b,
lapack_int ldb );
+lapack_int LAPACKE_clacp2( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const float* a, lapack_int lda,
+ lapack_complex_float* b, lapack_int ldb );
+lapack_int LAPACKE_zlacp2( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const double* a, lapack_int lda,
+ lapack_complex_double* b, lapack_int ldb );
+
lapack_int LAPACKE_zlag2c( int matrix_order, lapack_int m, lapack_int n,
const lapack_complex_double* a, lapack_int lda,
lapack_complex_float* sa, lapack_int ldsa );
@@ -6883,6 +6901,21 @@ lapack_int LAPACKE_clacgv_work( lapack_int n, lapack_complex_float* x,
lapack_int LAPACKE_zlacgv_work( lapack_int n, lapack_complex_double* x,
lapack_int incx );
+lapack_int LAPACKE_slacn2_work( lapack_int n, float* v, float* x,
+ lapack_int* isgn, float* est, lapack_int* kase,
+ lapack_int* isave );
+lapack_int LAPACKE_dlacn2_work( lapack_int n, double* v, double* x,
+ lapack_int* isgn, double* est, lapack_int* kase,
+ lapack_int* isave );
+lapack_int LAPACKE_clacn2_work( lapack_int n, lapack_complex_float* v,
+ lapack_complex_float* x,
+ float* est, lapack_int* kase,
+ lapack_int* isave );
+lapack_int LAPACKE_zlacn2_work( lapack_int n, lapack_complex_double* v,
+ lapack_complex_double* x,
+ double* est, lapack_int* kase,
+ lapack_int* isave );
+
lapack_int LAPACKE_slacpy_work( int matrix_order, char uplo, lapack_int m,
lapack_int n, const float* a, lapack_int lda,
float* b, lapack_int ldb );
@@ -6898,6 +6931,13 @@ lapack_int LAPACKE_zlacpy_work( int matrix_order, char uplo, lapack_int m,
lapack_int lda, lapack_complex_double* b,
lapack_int ldb );
+lapack_int LAPACKE_clacp2_work( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const float* a, lapack_int lda,
+ lapack_complex_float* b, lapack_int ldb );
+lapack_int LAPACKE_zlacp2_work( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const double* a, lapack_int lda,
+ lapack_complex_double* b, lapack_int ldb );
+
lapack_int LAPACKE_zlag2c_work( int matrix_order, lapack_int m, lapack_int n,
const lapack_complex_double* a, lapack_int lda,
lapack_complex_float* sa, lapack_int ldsa );
@@ -8779,6 +8819,27 @@ lapack_int LAPACKE_zsysv_work( int matrix_order, char uplo, lapack_int n,
lapack_complex_double* b, lapack_int ldb,
lapack_complex_double* work, lapack_int lwork );
+lapack_int LAPACKE_ssysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, float* a, lapack_int lda,
+ lapack_int* ipiv, float* b, lapack_int ldb,
+ float* work, lapack_int lwork );
+lapack_int LAPACKE_dsysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, double* a, lapack_int lda,
+ lapack_int* ipiv, double* b, lapack_int ldb,
+ double* work, lapack_int lwork );
+lapack_int LAPACKE_csysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_float* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_float* b, lapack_int ldb,
+ lapack_complex_float* work,
+ lapack_int lwork );
+lapack_int LAPACKE_zsysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_double* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_double* b, lapack_int ldb,
+ lapack_complex_double* work,
+ lapack_int lwork );
+
lapack_int LAPACKE_ssysvx_work( int matrix_order, char fact, char uplo,
lapack_int n, lapack_int nrhs, const float* a,
lapack_int lda, float* af, lapack_int ldaf,
@@ -10593,6 +10654,20 @@ lapack_int LAPACKE_ztprfb_work( int matrix_order, char side, char trans,
lapack_complex_double* b, lapack_int ldb,
const double* work, lapack_int ldwork );
//LAPACK 3.X.X
+lapack_int LAPACKE_ssysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, float* a, lapack_int lda,
+ lapack_int* ipiv, float* b, lapack_int ldb );
+lapack_int LAPACKE_dsysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, double* a, lapack_int lda,
+ lapack_int* ipiv, double* b, lapack_int ldb );
+lapack_int LAPACKE_csysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_float* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_float* b, lapack_int ldb );
+lapack_int LAPACKE_zsysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_double* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_double* b, lapack_int ldb );
lapack_int LAPACKE_csyr( int matrix_order, char uplo, lapack_int n,
lapack_complex_float alpha,
const lapack_complex_float* x, lapack_int incx,
@@ -10602,6 +10677,26 @@ lapack_int LAPACKE_zsyr( int matrix_order, char uplo, lapack_int n,
const lapack_complex_double* x, lapack_int incx,
lapack_complex_double* a, lapack_int lda );
+lapack_int LAPACKE_ssysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, float* a, lapack_int lda,
+ lapack_int* ipiv, float* b, lapack_int ldb,
+ float* work, lapack_int lwork );
+lapack_int LAPACKE_dsysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, double* a, lapack_int lda,
+ lapack_int* ipiv, double* b, lapack_int ldb,
+ double* work, lapack_int lwork );
+lapack_int LAPACKE_csysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_float* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_float* b, lapack_int ldb,
+ lapack_complex_float* work,
+ lapack_int lwork );
+lapack_int LAPACKE_zsysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_double* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_double* b, lapack_int ldb,
+ lapack_complex_double* work,
+ lapack_int lwork );
lapack_int LAPACKE_csyr_work( int matrix_order, char uplo, lapack_int n,
lapack_complex_float alpha,
const lapack_complex_float* x,
@@ -11485,10 +11580,16 @@ void LAPACKE_ilaver( const lapack_int* vers_major,
#define LAPACK_dgeqr2 LAPACK_GLOBAL(dgeqr2,DGEQR2)
#define LAPACK_cgeqr2 LAPACK_GLOBAL(cgeqr2,CGEQR2)
#define LAPACK_zgeqr2 LAPACK_GLOBAL(zgeqr2,ZGEQR2)
+#define LAPACK_slacn2 LAPACK_GLOBAL(slacn2,SLACN2)
+#define LAPACK_dlacn2 LAPACK_GLOBAL(dlacn2,DLACN2)
+#define LAPACK_clacn2 LAPACK_GLOBAL(clacn2,CLACN2)
+#define LAPACK_zlacn2 LAPACK_GLOBAL(zlacn2,ZLACN2)
#define LAPACK_slacpy LAPACK_GLOBAL(slacpy,SLACPY)
#define LAPACK_dlacpy LAPACK_GLOBAL(dlacpy,DLACPY)
#define LAPACK_clacpy LAPACK_GLOBAL(clacpy,CLACPY)
#define LAPACK_zlacpy LAPACK_GLOBAL(zlacpy,ZLACPY)
+#define LAPACK_clacp2 LAPACK_GLOBAL(clacp2,CLACP2)
+#define LAPACK_zlacp2 LAPACK_GLOBAL(zlacp2,ZLACP2)
#define LAPACK_sgetf2 LAPACK_GLOBAL(sgetf2,SGETF2)
#define LAPACK_dgetf2 LAPACK_GLOBAL(dgetf2,DGETF2)
#define LAPACK_cgetf2 LAPACK_GLOBAL(cgetf2,CGETF2)
@@ -11647,6 +11748,10 @@ void LAPACKE_ilaver( const lapack_int* vers_major,
#define LAPACK_ctprfb LAPACK_GLOBAL(ctprfb,CTPRFB)
#define LAPACK_ztprfb LAPACK_GLOBAL(ztprfb,ZTPRFB)
// LAPACK 3.X.X
+#define LAPACK_ssysv_rook LAPACK_GLOBAL(ssysv_rook,SSYSV_ROOK)
+#define LAPACK_dsysv_rook LAPACK_GLOBAL(dsysv_rook,DSYSV_ROOK)
+#define LAPACK_csysv_rook LAPACK_GLOBAL(csysv_rook,CSYSV_ROOK)
+#define LAPACK_zsysv_rook LAPACK_GLOBAL(zsysv_rook,ZSYSV_ROOK)
#define LAPACK_csyr LAPACK_GLOBAL(csyr,CSYR)
#define LAPACK_zsyr LAPACK_GLOBAL(zsyr,ZSYR)
#define LAPACK_ilaver LAPACK_GLOBAL(ilaver,ILAVER)
@@ -15672,6 +15777,16 @@ void LAPACK_cgeqr2( lapack_int* m, lapack_int* n, lapack_complex_float* a,
void LAPACK_zgeqr2( lapack_int* m, lapack_int* n, lapack_complex_double* a,
lapack_int* lda, lapack_complex_double* tau,
lapack_complex_double* work, lapack_int *info );
+void LAPACK_slacn2( lapack_int* n, float* v, float* x, lapack_int* isgn,
+ float* est, lapack_int* kase, lapack_int* isave );
+void LAPACK_dlacn2( lapack_int* n, double* v, double* x, lapack_int* isgn,
+ double* est, lapack_int* kase, lapack_int* isave );
+void LAPACK_clacn2( lapack_int* n, lapack_complex_float* v,
+ lapack_complex_float* x, float* est,
+ lapack_int* kase, lapack_int* isave );
+void LAPACK_zlacn2( lapack_int* n, lapack_complex_double* v,
+ lapack_complex_double* x, double* est,
+ lapack_int* kase, lapack_int* isave );
void LAPACK_slacpy( char* uplo, lapack_int* m, lapack_int* n, const float* a,
lapack_int* lda, float* b, lapack_int* ldb );
void LAPACK_dlacpy( char* uplo, lapack_int* m, lapack_int* n, const double* a,
@@ -15682,6 +15797,13 @@ void LAPACK_clacpy( char* uplo, lapack_int* m, lapack_int* n,
void LAPACK_zlacpy( char* uplo, lapack_int* m, lapack_int* n,
const lapack_complex_double* a, lapack_int* lda,
lapack_complex_double* b, lapack_int* ldb );
+
+void LAPACK_clacp2( char* uplo, lapack_int* m, lapack_int* n, const float* a,
+ lapack_int* lda, lapack_complex_float* b, lapack_int* ldb );
+void LAPACK_zlacp2( char* uplo, lapack_int* m, lapack_int* n, const double* a,
+ lapack_int* lda, lapack_complex_double* b,
+ lapack_int* ldb );
+
void LAPACK_sgetf2( lapack_int* m, lapack_int* n, float* a, lapack_int* lda,
lapack_int* ipiv, lapack_int *info );
void LAPACK_dgetf2( lapack_int* m, lapack_int* n, double* a, lapack_int* lda,
@@ -16288,7 +16410,25 @@ void LAPACK_ztprfb( char* side, char* trans, char* direct, char* storev,
lapack_complex_double* a, lapack_int* lda,
lapack_complex_double* b, lapack_int* ldb,
const double* work, lapack_int* ldwork );
-// LAPACK 3.X.X
+// LAPACK 3.5.0
+void LAPACK_ssysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, float* a,
+ lapack_int* lda, lapack_int* ipiv, float* b,
+ lapack_int* ldb, float* work, lapack_int* lwork,
+ lapack_int *info );
+void LAPACK_dsysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, double* a,
+ lapack_int* lda, lapack_int* ipiv, double* b,
+ lapack_int* ldb, double* work, lapack_int* lwork,
+ lapack_int *info );
+void LAPACK_csysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs,
+ lapack_complex_float* a, lapack_int* lda,
+ lapack_int* ipiv, lapack_complex_float* b,
+ lapack_int* ldb, lapack_complex_float* work,
+ lapack_int* lwork, lapack_int *info );
+void LAPACK_zsysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs,
+ lapack_complex_double* a, lapack_int* lda,
+ lapack_int* ipiv, lapack_complex_double* b,
+ lapack_int* ldb, lapack_complex_double* work,
+ lapack_int* lwork, lapack_int *info );
void LAPACK_csyr( char* uplo, lapack_int* n, lapack_complex_float* alpha,
const lapack_complex_float* x, lapack_int* incx,
lapack_complex_float* a, lapack_int* lda );
diff --git a/lapack-netlib/lapacke/src/CMakeLists.txt b/lapack-netlib/lapacke/src/CMakeLists.txt
index 56698172d..e1b5cfd57 100644
--- a/lapack-netlib/lapacke/src/CMakeLists.txt
+++ b/lapack-netlib/lapacke/src/CMakeLists.txt
@@ -233,6 +233,10 @@ lapacke_chseqr.c
lapacke_chseqr_work.c
lapacke_clacgv.c
lapacke_clacgv_work.c
+lapacke_clacn2.c
+lapacke_clacn2_work.c
+lapacke_clacp2.c
+lapacke_clacp2_work.c
lapacke_clacpy.c
lapacke_clacpy_work.c
lapacke_clag2z.c
@@ -368,6 +372,8 @@ lapacke_csyequb_work.c
lapacke_csyrfs.c
lapacke_csyrfs_work.c
lapacke_csysv.c
+lapacke_csysv_rook.c
+lapacke_csysv_rook_work.c
lapacke_csysv_work.c
lapacke_csysvx.c
lapacke_csysvx_work.c
@@ -641,6 +647,8 @@ lapacke_dhsein.c
lapacke_dhsein_work.c
lapacke_dhseqr.c
lapacke_dhseqr_work.c
+lapacke_dlacn2.c
+lapacke_dlacn2_work.c
lapacke_dlacpy.c
lapacke_dlacpy_work.c
lapacke_dlag2s.c
@@ -890,6 +898,8 @@ lapacke_dsygvx_work.c
lapacke_dsyrfs.c
lapacke_dsyrfs_work.c
lapacke_dsysv.c
+lapacke_dsysv_rook.c
+lapacke_dsysv_rook_work.c
lapacke_dsysv_work.c
lapacke_dsysvx.c
lapacke_dsysvx_work.c
@@ -1127,6 +1137,8 @@ lapacke_shsein.c
lapacke_shsein_work.c
lapacke_shseqr.c
lapacke_shseqr_work.c
+lapacke_slacn2.c
+lapacke_slacn2_work.c
lapacke_slacpy.c
lapacke_slacpy_work.c
lapacke_slag2d.c
@@ -1372,6 +1384,8 @@ lapacke_ssygvx_work.c
lapacke_ssyrfs.c
lapacke_ssyrfs_work.c
lapacke_ssysv.c
+lapacke_ssysv_rook.c
+lapacke_ssysv_rook_work.c
lapacke_ssysv_work.c
lapacke_ssysvx.c
lapacke_ssysvx_work.c
@@ -1695,6 +1709,10 @@ lapacke_zhseqr.c
lapacke_zhseqr_work.c
lapacke_zlacgv.c
lapacke_zlacgv_work.c
+lapacke_zlacn2.c
+lapacke_zlacn2_work.c
+lapacke_zlacp2.c
+lapacke_zlacp2_work.c
lapacke_zlacpy.c
lapacke_zlacpy_work.c
lapacke_zlag2c.c
@@ -1830,6 +1848,8 @@ lapacke_zsyequb_work.c
lapacke_zsyrfs.c
lapacke_zsyrfs_work.c
lapacke_zsysv.c
+lapacke_zsysv_rook.c
+lapacke_zsysv_rook_work.c
lapacke_zsysv_work.c
lapacke_zsysvx.c
lapacke_zsysvx_work.c
@@ -2007,4 +2027,4 @@ lapacke_slagsy.c
lapacke_slagsy_work.c
lapacke_zlagsy.c
lapacke_zlagsy_work.c
-)
\ No newline at end of file
+)
diff --git a/lapack-netlib/lapacke/src/Makefile b/lapack-netlib/lapacke/src/Makefile
index 6297b9e76..51a947e22 100644
--- a/lapack-netlib/lapacke/src/Makefile
+++ b/lapack-netlib/lapacke/src/Makefile
@@ -34,7 +34,7 @@
#
include ../../make.inc
-CSRC_OBJ = \
+SRC_OBJ = \
lapacke_cbbcsd.o \
lapacke_cbbcsd_work.o \
lapacke_cbdsqr.o \
@@ -267,6 +267,10 @@ lapacke_chseqr.o \
lapacke_chseqr_work.o \
lapacke_clacgv.o \
lapacke_clacgv_work.o \
+lapacke_clacn2.o \
+lapacke_clacn2_work.o \
+lapacke_clacp2.o \
+lapacke_clacp2_work.o \
lapacke_clacpy.o \
lapacke_clacpy_work.o \
lapacke_clag2z.o \
@@ -402,6 +406,8 @@ lapacke_csyequb_work.o \
lapacke_csyrfs.o \
lapacke_csyrfs_work.o \
lapacke_csysv.o \
+lapacke_csysv_rook.o \
+lapacke_csysv_rook_work.o \
lapacke_csysv_work.o \
lapacke_csysvx.o \
lapacke_csysvx_work.o \
@@ -526,9 +532,7 @@ lapacke_cunmtr_work.o \
lapacke_cupgtr.o \
lapacke_cupgtr_work.o \
lapacke_cupmtr.o \
-lapacke_cupmtr_work.o
-
-DSRC_OBJ = \
+lapacke_cupmtr_work.o \
lapacke_dbbcsd.o \
lapacke_dbbcsd_work.o \
lapacke_dbdsdc.o \
@@ -677,6 +681,8 @@ lapacke_dhsein.o \
lapacke_dhsein_work.o \
lapacke_dhseqr.o \
lapacke_dhseqr_work.o \
+lapacke_dlacn2.o \
+lapacke_dlacn2_work.o \
lapacke_dlacpy.o \
lapacke_dlacpy_work.o \
lapacke_dlag2s.o \
@@ -926,6 +932,8 @@ lapacke_dsygvx_work.o \
lapacke_dsyrfs.o \
lapacke_dsyrfs_work.o \
lapacke_dsysv.o \
+lapacke_dsysv_rook.o \
+lapacke_dsysv_rook_work.o \
lapacke_dsysv_work.o \
lapacke_dsysvx.o \
lapacke_dsysvx_work.o \
@@ -1014,9 +1022,7 @@ lapacke_dtrttf_work.o \
lapacke_dtrttp.o \
lapacke_dtrttp_work.o \
lapacke_dtzrzf.o \
-lapacke_dtzrzf_work.o
-
-SSRC_OBJ = \
+lapacke_dtzrzf_work.o \
lapacke_sbbcsd.o \
lapacke_sbbcsd_work.o \
lapacke_sbdsdc.o \
@@ -1165,6 +1171,8 @@ lapacke_shsein.o \
lapacke_shsein_work.o \
lapacke_shseqr.o \
lapacke_shseqr_work.o \
+lapacke_slacn2.o \
+lapacke_slacn2_work.o \
lapacke_slacpy.o \
lapacke_slacpy_work.o \
lapacke_slag2d.o \
@@ -1410,6 +1418,8 @@ lapacke_ssygvx_work.o \
lapacke_ssyrfs.o \
lapacke_ssyrfs_work.o \
lapacke_ssysv.o \
+lapacke_ssysv_rook.o \
+lapacke_ssysv_rook_work.o \
lapacke_ssysv_work.o \
lapacke_ssysvx.o \
lapacke_ssysvx_work.o \
@@ -1496,9 +1506,7 @@ lapacke_strttf_work.o \
lapacke_strttp.o \
lapacke_strttp_work.o \
lapacke_stzrzf.o \
-lapacke_stzrzf_work.o
-
-ZSRC_OBJ = \
+lapacke_stzrzf_work.o \
lapacke_zbbcsd.o \
lapacke_zbbcsd_work.o \
lapacke_zbdsqr.o \
@@ -1735,6 +1743,10 @@ lapacke_zhseqr.o \
lapacke_zhseqr_work.o \
lapacke_zlacgv.o \
lapacke_zlacgv_work.o \
+lapacke_zlacn2.o \
+lapacke_zlacn2_work.o \
+lapacke_zlacp2.o \
+lapacke_zlacp2_work.o \
lapacke_zlacpy.o \
lapacke_zlacpy_work.o \
lapacke_zlag2c.o \
@@ -1870,6 +1882,8 @@ lapacke_zsyequb_work.o \
lapacke_zsyrfs.o \
lapacke_zsyrfs_work.o \
lapacke_zsysv.o \
+lapacke_zsysv_rook.o \
+lapacke_zsysv_rook_work.o \
lapacke_zsysv_work.o \
lapacke_zsysvx.o \
lapacke_zsysvx_work.o \
@@ -2047,29 +2061,24 @@ lapacke_slagsy_work.o \
lapacke_zlagsy.o \
lapacke_zlagsy_work.o
-COBJ_FILES := $(CSRC_OBJ)
-SOBJ_FILES := $(SSRC_OBJ)
-DOBJ_FILES := $(DSRC_OBJ)
-ZOBJ_FILES := $(ZSRC_OBJ)
-ifdef LAPACKE_EXTENDED
-OBJ_FILES += $(SRCX_OBJ)
-endif
+ALLOBJ = $(SRC_OBJ)
ifdef LAPACKE_TESTING
-OBJ_FILES += $(MATGEN_OBJ)
+ALLOBJ += $(MATGEN_OBJ)
endif
+ifdef USEXBLAS
+ALLXOBJ = $(SXLASRC) $(DXLASRC) $(CXLASRC) $(ZXLASRC)
+endif
+
+
+OBJ_FILES := $(C_FILES:.o=.o)
+
all: ../../$(LAPACKELIB)
-../../$(LAPACKELIB): $(COBJ_FILES) $(DOBJ_FILES) $(SOBJ_FILES) $(ZOBJ_FILES) $(OBJ_FILES)
- $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(COBJ_FILES)
- $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(DOBJ_FILES)
- $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(SOBJ_FILES)
- $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(ZOBJ_FILES)
-ifneq ($(strip $(OBJ_FILES)),)
- $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(OBJ_FILES)
-endif
+../../$(LAPACKELIB): $(ALLOBJ) $(ALLXOBJ)
+ $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(ALLOBJ) $(ALLXOBJ)
$(RANLIB) ../../$(LAPACKELIB)
.c.o:
diff --git a/lapack-netlib/lapacke/src/lapacke_clacn2.c b/lapack-netlib/lapacke/src/lapacke_clacn2.c
new file mode 100644
index 000000000..890c486f8
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_clacn2.c
@@ -0,0 +1,50 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 clacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_clacn2( lapack_int n, lapack_complex_float* v,
+ lapack_complex_float* x,
+ float* est, lapack_int* kase, lapack_int* isave )
+{
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_s_nancheck( 1, est, 1 ) ) {
+ return -5;
+ }
+ if( LAPACKE_c_nancheck( n, x, 1 ) ) {
+ return -3;
+ }
+#endif
+ return LAPACKE_clacn2_work( n, v, x, est, kase, isave );
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_clacn2_work.c b/lapack-netlib/lapacke/src/lapacke_clacn2_work.c
new file mode 100644
index 000000000..970b7d7dd
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_clacn2_work.c
@@ -0,0 +1,45 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 clacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_clacn2_work( lapack_int n, lapack_complex_float* v,
+ lapack_complex_float* x,
+ float* est, lapack_int* kase,
+ lapack_int* isave )
+{
+ lapack_int info = 0;
+ /* Call LAPACK function and adjust info */
+ LAPACK_clacn2( &n, v, x, est, kase, isave );
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_clacp2.c b/lapack-netlib/lapacke/src/lapacke_clacp2.c
new file mode 100644
index 000000000..fa7e825f9
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_clacp2.c
@@ -0,0 +1,51 @@
+/*****************************************************************************
+ Copyright (c) 2011, 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 clacp2
+* Author: Intel Corporation
+* Generated January, 2013
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_clacp2( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const float* a, lapack_int lda,
+ lapack_complex_float* b, lapack_int ldb )
+{
+ if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) {
+ LAPACKE_xerbla( "LAPACKE_clacp2", -1 );
+ return -1;
+ }
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_sge_nancheck( matrix_order, m, n, a, lda ) ) {
+ return -5;
+ }
+#endif
+ return LAPACKE_clacp2_work( matrix_order, uplo, m, n, a, lda, b, ldb );
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_clacp2_work.c b/lapack-netlib/lapacke/src/lapacke_clacp2_work.c
new file mode 100644
index 000000000..479fd9c2b
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_clacp2_work.c
@@ -0,0 +1,96 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 clacp2
+* Author: Intel Corporation
+* Generated January, 2013
+*****************************************************************************/
+
+#include "lapacke.h"
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_clacp2_work( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const float* a, lapack_int lda,
+ lapack_complex_float* b, lapack_int ldb )
+{
+ lapack_int info = 0;
+ if( matrix_order == LAPACK_COL_MAJOR ) {
+ /* Call LAPACK function and adjust info */
+ LAPACK_clacp2( &uplo, &m, &n, a, &lda, b, &ldb );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ } else if( matrix_order == LAPACK_ROW_MAJOR ) {
+ lapack_int lda_t = MAX(1,m);
+ lapack_int ldb_t = MAX(1,m);
+ float* a_t = NULL;
+ lapack_complex_float* b_t = NULL;
+ /* Check leading dimension(s) */
+ if( lda < n ) {
+ info = -6;
+ LAPACKE_xerbla( "LAPACKE_clacp2_work", info );
+ return info;
+ }
+ if( ldb < n ) {
+ info = -8;
+ LAPACKE_xerbla( "LAPACKE_clacp2_work", info );
+ return 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;
+ }
+ b_t = (lapack_complex_float*)
+ LAPACKE_malloc( sizeof(lapack_complex_float) * ldb_t * MAX(1,n) );
+ if( b_t == NULL ) {
+ info = LAPACK_TRANSPOSE_MEMORY_ERROR;
+ goto exit_level_1;
+ }
+ /* Transpose input matrices */
+ LAPACKE_sge_trans( matrix_order, m, n, a, lda, a_t, lda_t );
+ /* Call LAPACK function and adjust info */
+ LAPACK_clacp2( &uplo, &m, &n, a_t, &lda_t, b_t, &ldb_t );
+ info = 0; /* LAPACK call is ok! */
+ /* Transpose output matrices */
+ LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, b_t, ldb_t, b, ldb );
+ /* Release memory and exit */
+ LAPACKE_free( b_t );
+exit_level_1:
+ LAPACKE_free( a_t );
+exit_level_0:
+ if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_clacp2_work", info );
+ }
+ } else {
+ info = -1;
+ LAPACKE_xerbla( "LAPACKE_clacp2_work", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_cstegr_work.c b/lapack-netlib/lapacke/src/lapacke_cstegr_work.c
index afd889662..a7ede3a49 100644
--- a/lapack-netlib/lapacke/src/lapacke_cstegr_work.c
+++ b/lapack-netlib/lapacke/src/lapacke_cstegr_work.c
@@ -55,7 +55,7 @@ lapack_int LAPACKE_cstegr_work( int matrix_order, char jobz, char range,
lapack_int ldz_t = MAX(1,n);
lapack_complex_float* z_t = NULL;
/* Check leading dimension(s) */
- if( ldz < *m ) {
+ if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) {
info = -15;
LAPACKE_xerbla( "LAPACKE_cstegr_work", info );
return info;
diff --git a/lapack-netlib/lapacke/src/lapacke_csysv_rook.c b/lapack-netlib/lapacke/src/lapacke_csysv_rook.c
new file mode 100644
index 000000000..e67768ca8
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_csysv_rook.c
@@ -0,0 +1,82 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 csysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_csysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_float* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_float* b, lapack_int ldb )
+{
+ lapack_int info = 0;
+ lapack_int lwork = -1;
+ lapack_complex_float* work = NULL;
+ lapack_complex_float work_query;
+ if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) {
+ LAPACKE_xerbla( "LAPACKE_csysv_rook", -1 );
+ return -1;
+ }
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_csy_nancheck( matrix_order, uplo, n, a, lda ) ) {
+ return -5;
+ }
+ if( LAPACKE_cge_nancheck( matrix_order, n, nrhs, b, ldb ) ) {
+ return -8;
+ }
+#endif
+ /* Query optimal working array(s) size */
+ info = LAPACKE_csysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, &work_query, lwork );
+ if( info != 0 ) {
+ goto exit_level_0;
+ }
+ lwork = LAPACK_C2INT( work_query );
+ /* Allocate memory for work arrays */
+ work = (lapack_complex_float*)
+ LAPACKE_malloc( sizeof(lapack_complex_float) * lwork );
+ if( work == NULL ) {
+ info = LAPACK_WORK_MEMORY_ERROR;
+ goto exit_level_0;
+ }
+ /* Call middle-level interface */
+ info = LAPACKE_csysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, work, lwork );
+ /* Release memory and exit */
+ LAPACKE_free( work );
+exit_level_0:
+ if( info == LAPACK_WORK_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_csysv_rook", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_csysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_csysv_rook_work.c
new file mode 100644
index 000000000..5c173187e
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_csysv_rook_work.c
@@ -0,0 +1,112 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 csysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_csysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_float* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_float* b, lapack_int ldb,
+ lapack_complex_float* work,
+ lapack_int lwork )
+{
+ lapack_int info = 0;
+ if( matrix_order == LAPACK_COL_MAJOR ) {
+ /* Call LAPACK function and adjust info */
+ LAPACK_csysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work,
+ &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ } else if( matrix_order == LAPACK_ROW_MAJOR ) {
+ lapack_int lda_t = MAX(1,n);
+ lapack_int ldb_t = MAX(1,n);
+ lapack_complex_float* a_t = NULL;
+ lapack_complex_float* b_t = NULL;
+ /* Check leading dimension(s) */
+ if( lda < n ) {
+ info = -6;
+ LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info );
+ return info;
+ }
+ if( ldb < nrhs ) {
+ info = -9;
+ LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info );
+ return info;
+ }
+ /* Query optimal working array(s) size if requested */
+ if( lwork == -1 ) {
+ LAPACK_csysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t,
+ work, &lwork, &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;
+ }
+ b_t = (lapack_complex_float*)
+ LAPACKE_malloc( sizeof(lapack_complex_float) *
+ ldb_t * MAX(1,nrhs) );
+ if( b_t == NULL ) {
+ info = LAPACK_TRANSPOSE_MEMORY_ERROR;
+ goto exit_level_1;
+ }
+ /* Transpose input matrices */
+ LAPACKE_csy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t );
+ LAPACKE_cge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t );
+ /* Call LAPACK function and adjust info */
+ LAPACK_csysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t,
+ work, &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ /* Transpose output matrices */
+ LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda );
+ LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb );
+ /* Release memory and exit */
+ LAPACKE_free( b_t );
+exit_level_1:
+ LAPACKE_free( a_t );
+exit_level_0:
+ if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info );
+ }
+ } else {
+ info = -1;
+ LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_dlacn2.c b/lapack-netlib/lapacke/src/lapacke_dlacn2.c
new file mode 100644
index 000000000..1ccf0a9da
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_dlacn2.c
@@ -0,0 +1,49 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 dlacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_dlacn2( lapack_int n, double* v, double* x, lapack_int* isgn,
+ double* est, lapack_int* kase, lapack_int* isave )
+{
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_d_nancheck( 1, est, 1 ) ) {
+ return -5;
+ }
+ if( LAPACKE_d_nancheck( n, x, 1 ) ) {
+ return -3;
+ }
+#endif
+ return LAPACKE_dlacn2_work( n, v, x, isgn, est, kase, isave );
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_dlacn2_work.c b/lapack-netlib/lapacke/src/lapacke_dlacn2_work.c
new file mode 100644
index 000000000..3b015d4e1
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_dlacn2_work.c
@@ -0,0 +1,44 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 dlacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_dlacn2_work( lapack_int n, double* v, double* x,
+ lapack_int* isgn, double* est, lapack_int* kase,
+ lapack_int* isave )
+{
+ lapack_int info = 0;
+ /* Call LAPACK function and adjust info */
+ LAPACK_dlacn2( &n, v, x, isgn, est, kase, isave );
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_dstegr_work.c b/lapack-netlib/lapacke/src/lapacke_dstegr_work.c
index 0bec6530d..26ab31e54 100644
--- a/lapack-netlib/lapacke/src/lapacke_dstegr_work.c
+++ b/lapack-netlib/lapacke/src/lapacke_dstegr_work.c
@@ -54,7 +54,7 @@ lapack_int LAPACKE_dstegr_work( int matrix_order, char jobz, char range,
lapack_int ldz_t = MAX(1,n);
double* z_t = NULL;
/* Check leading dimension(s) */
- if( ldz < *m ) {
+ if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) {
info = -15;
LAPACKE_xerbla( "LAPACKE_dstegr_work", info );
return info;
diff --git a/lapack-netlib/lapacke/src/lapacke_dsysv_rook.c b/lapack-netlib/lapacke/src/lapacke_dsysv_rook.c
new file mode 100644
index 000000000..d6af2e4b1
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_dsysv_rook.c
@@ -0,0 +1,80 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 dsysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_dsysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, double* a, lapack_int lda,
+ lapack_int* ipiv, double* b, lapack_int ldb )
+{
+ lapack_int info = 0;
+ lapack_int lwork = -1;
+ double* work = NULL;
+ double work_query;
+ if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) {
+ LAPACKE_xerbla( "LAPACKE_dsysv_rook", -1 );
+ return -1;
+ }
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_dsy_nancheck( matrix_order, uplo, n, a, lda ) ) {
+ return -5;
+ }
+ if( LAPACKE_dge_nancheck( matrix_order, n, nrhs, b, ldb ) ) {
+ return -8;
+ }
+#endif
+ /* Query optimal working array(s) size */
+ info = LAPACKE_dsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, &work_query, lwork );
+ if( info != 0 ) {
+ goto exit_level_0;
+ }
+ lwork = (lapack_int)work_query;
+ /* Allocate memory for work arrays */
+ work = (double*)LAPACKE_malloc( sizeof(double) * lwork );
+ if( work == NULL ) {
+ info = LAPACK_WORK_MEMORY_ERROR;
+ goto exit_level_0;
+ }
+ /* Call middle-level interface */
+ info = LAPACKE_dsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, work, lwork );
+ /* Release memory and exit */
+ LAPACKE_free( work );
+exit_level_0:
+ if( info == LAPACK_WORK_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_dsysv_rook", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_dsysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_dsysv_rook_work.c
new file mode 100644
index 000000000..1932ec1da
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_dsysv_rook_work.c
@@ -0,0 +1,107 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 dsysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_dsysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, double* a, lapack_int lda,
+ lapack_int* ipiv, double* b, lapack_int ldb,
+ double* work, lapack_int lwork )
+{
+ lapack_int info = 0;
+ if( matrix_order == LAPACK_COL_MAJOR ) {
+ /* Call LAPACK function and adjust info */
+ LAPACK_dsysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work,
+ &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ } else if( matrix_order == LAPACK_ROW_MAJOR ) {
+ lapack_int lda_t = MAX(1,n);
+ lapack_int ldb_t = MAX(1,n);
+ double* a_t = NULL;
+ double* b_t = NULL;
+ /* Check leading dimension(s) */
+ if( lda < n ) {
+ info = -6;
+ LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info );
+ return info;
+ }
+ if( ldb < nrhs ) {
+ info = -9;
+ LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info );
+ return info;
+ }
+ /* Query optimal working array(s) size if requested */
+ if( lwork == -1 ) {
+ LAPACK_dsysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t,
+ work, &lwork, &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;
+ }
+ b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) );
+ if( b_t == NULL ) {
+ info = LAPACK_TRANSPOSE_MEMORY_ERROR;
+ goto exit_level_1;
+ }
+ /* Transpose input matrices */
+ LAPACKE_dsy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t );
+ LAPACKE_dge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t );
+ /* Call LAPACK function and adjust info */
+ LAPACK_dsysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t,
+ work, &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ /* Transpose output matrices */
+ LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda );
+ LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb );
+ /* Release memory and exit */
+ LAPACKE_free( b_t );
+exit_level_1:
+ LAPACKE_free( a_t );
+exit_level_0:
+ if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info );
+ }
+ } else {
+ info = -1;
+ LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_slacn2.c b/lapack-netlib/lapacke/src/lapacke_slacn2.c
new file mode 100644
index 000000000..15d06d551
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_slacn2.c
@@ -0,0 +1,49 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 slacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_slacn2( lapack_int n, float* v, float* x, lapack_int* isgn,
+ float* est, lapack_int* kase, lapack_int* isave )
+{
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_s_nancheck( 1, est, 1 ) ) {
+ return -5;
+ }
+ if( LAPACKE_s_nancheck( n, x, 1 ) ) {
+ return -3;
+ }
+#endif
+ return LAPACKE_slacn2_work( n, v, x, isgn, est, kase, isave );
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_slacn2_work.c b/lapack-netlib/lapacke/src/lapacke_slacn2_work.c
new file mode 100644
index 000000000..7908d41c6
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_slacn2_work.c
@@ -0,0 +1,44 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 slacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_slacn2_work( lapack_int n, float* v, float* x,
+ lapack_int* isgn, float* est, lapack_int* kase,
+ lapack_int* isave )
+{
+ lapack_int info = 0;
+ /* Call LAPACK function and adjust info */
+ LAPACK_slacn2( &n, v, x, isgn, est, kase, isave );
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_sstegr_work.c b/lapack-netlib/lapacke/src/lapacke_sstegr_work.c
index 90188d26e..54bc3d21f 100644
--- a/lapack-netlib/lapacke/src/lapacke_sstegr_work.c
+++ b/lapack-netlib/lapacke/src/lapacke_sstegr_work.c
@@ -54,7 +54,7 @@ lapack_int LAPACKE_sstegr_work( int matrix_order, char jobz, char range,
lapack_int ldz_t = MAX(1,n);
float* z_t = NULL;
/* Check leading dimension(s) */
- if( ldz < *m ) {
+ if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) {
info = -15;
LAPACKE_xerbla( "LAPACKE_sstegr_work", info );
return info;
diff --git a/lapack-netlib/lapacke/src/lapacke_ssysv_rook.c b/lapack-netlib/lapacke/src/lapacke_ssysv_rook.c
new file mode 100644
index 000000000..dfa5a7815
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_ssysv_rook.c
@@ -0,0 +1,80 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 ssysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_ssysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, float* a, lapack_int lda,
+ lapack_int* ipiv, float* b, lapack_int ldb )
+{
+ lapack_int info = 0;
+ lapack_int lwork = -1;
+ float* work = NULL;
+ float work_query;
+ if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) {
+ LAPACKE_xerbla( "LAPACKE_ssysv_rook", -1 );
+ return -1;
+ }
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_ssy_nancheck( matrix_order, uplo, n, a, lda ) ) {
+ return -5;
+ }
+ if( LAPACKE_sge_nancheck( matrix_order, n, nrhs, b, ldb ) ) {
+ return -8;
+ }
+#endif
+ /* Query optimal working array(s) size */
+ info = LAPACKE_ssysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, &work_query, lwork );
+ if( info != 0 ) {
+ goto exit_level_0;
+ }
+ lwork = (lapack_int)work_query;
+ /* Allocate memory for work arrays */
+ work = (float*)LAPACKE_malloc( sizeof(float) * lwork );
+ if( work == NULL ) {
+ info = LAPACK_WORK_MEMORY_ERROR;
+ goto exit_level_0;
+ }
+ /* Call middle-level interface */
+ info = LAPACKE_ssysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, work, lwork );
+ /* Release memory and exit */
+ LAPACKE_free( work );
+exit_level_0:
+ if( info == LAPACK_WORK_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_ssysv_rook", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_ssysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_ssysv_rook_work.c
new file mode 100644
index 000000000..c6449fe11
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_ssysv_rook_work.c
@@ -0,0 +1,107 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 ssysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_ssysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, float* a, lapack_int lda,
+ lapack_int* ipiv, float* b, lapack_int ldb,
+ float* work, lapack_int lwork )
+{
+ lapack_int info = 0;
+ if( matrix_order == LAPACK_COL_MAJOR ) {
+ /* Call LAPACK function and adjust info */
+ LAPACK_ssysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work,
+ &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ } else if( matrix_order == LAPACK_ROW_MAJOR ) {
+ lapack_int lda_t = MAX(1,n);
+ lapack_int ldb_t = MAX(1,n);
+ float* a_t = NULL;
+ float* b_t = NULL;
+ /* Check leading dimension(s) */
+ if( lda < n ) {
+ info = -6;
+ LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info );
+ return info;
+ }
+ if( ldb < nrhs ) {
+ info = -9;
+ LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info );
+ return info;
+ }
+ /* Query optimal working array(s) size if requested */
+ if( lwork == -1 ) {
+ LAPACK_ssysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t,
+ work, &lwork, &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;
+ }
+ b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) );
+ if( b_t == NULL ) {
+ info = LAPACK_TRANSPOSE_MEMORY_ERROR;
+ goto exit_level_1;
+ }
+ /* Transpose input matrices */
+ LAPACKE_ssy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t );
+ LAPACKE_sge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t );
+ /* Call LAPACK function and adjust info */
+ LAPACK_ssysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t,
+ work, &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ /* Transpose output matrices */
+ LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda );
+ LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb );
+ /* Release memory and exit */
+ LAPACKE_free( b_t );
+exit_level_1:
+ LAPACKE_free( a_t );
+exit_level_0:
+ if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info );
+ }
+ } else {
+ info = -1;
+ LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_zlacn2.c b/lapack-netlib/lapacke/src/lapacke_zlacn2.c
new file mode 100644
index 000000000..e64c0716a
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_zlacn2.c
@@ -0,0 +1,50 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 zlacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_zlacn2( lapack_int n, lapack_complex_double* v,
+ lapack_complex_double* x,
+ double* est, lapack_int* kase, lapack_int* isave )
+{
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_d_nancheck( 1, est, 1 ) ) {
+ return -5;
+ }
+ if( LAPACKE_z_nancheck( n, x, 1 ) ) {
+ return -3;
+ }
+#endif
+ return LAPACKE_zlacn2_work( n, v, x, est, kase, isave );
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_zlacn2_work.c b/lapack-netlib/lapacke/src/lapacke_zlacn2_work.c
new file mode 100644
index 000000000..6babae5a2
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_zlacn2_work.c
@@ -0,0 +1,45 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 zlacn2
+* Author: Intel Corporation
+* Generated October, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_zlacn2_work( lapack_int n, lapack_complex_double* v,
+ lapack_complex_double* x,
+ double* est, lapack_int* kase,
+ lapack_int* isave )
+{
+ lapack_int info = 0;
+ /* Call LAPACK function and adjust info */
+ LAPACK_zlacn2( &n, v, x, est, kase, isave );
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_zlacp2.c b/lapack-netlib/lapacke/src/lapacke_zlacp2.c
new file mode 100644
index 000000000..ffcaac91a
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_zlacp2.c
@@ -0,0 +1,51 @@
+/*****************************************************************************
+ Copyright (c) 2011, 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 zlacp2
+* Author: Intel Corporation
+* Generated January, 2013
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_zlacp2( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const double* a, lapack_int lda,
+ lapack_complex_double* b, lapack_int ldb )
+{
+ if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) {
+ LAPACKE_xerbla( "LAPACKE_zlacp2", -1 );
+ return -1;
+ }
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_dge_nancheck( matrix_order, m, n, a, lda ) ) {
+ return -5;
+ }
+#endif
+ return LAPACKE_zlacp2_work( matrix_order, uplo, m, n, a, lda, b, ldb );
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_zlacp2_work.c b/lapack-netlib/lapacke/src/lapacke_zlacp2_work.c
new file mode 100644
index 000000000..8ece4914c
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_zlacp2_work.c
@@ -0,0 +1,96 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 zlacp2
+* Author: Intel Corporation
+* Generated January, 2013
+*****************************************************************************/
+
+#include "lapacke.h"
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_zlacp2_work( int matrix_order, char uplo, lapack_int m,
+ lapack_int n, const double* a, lapack_int lda,
+ lapack_complex_double* b, lapack_int ldb )
+{
+ lapack_int info = 0;
+ if( matrix_order == LAPACK_COL_MAJOR ) {
+ /* Call LAPACK function and adjust info */
+ LAPACK_zlacp2( &uplo, &m, &n, a, &lda, b, &ldb );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ } else if( matrix_order == LAPACK_ROW_MAJOR ) {
+ lapack_int lda_t = MAX(1,m);
+ lapack_int ldb_t = MAX(1,m);
+ double* a_t = NULL;
+ lapack_complex_double* b_t = NULL;
+ /* Check leading dimension(s) */
+ if( lda < n ) {
+ info = -6;
+ LAPACKE_xerbla( "LAPACKE_zlacp2_work", info );
+ return info;
+ }
+ if( ldb < n ) {
+ info = -8;
+ LAPACKE_xerbla( "LAPACKE_zlacp2_work", info );
+ return 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;
+ }
+ b_t = (lapack_complex_double*)
+ LAPACKE_malloc( sizeof(lapack_complex_double) * ldb_t * MAX(1,n) );
+ if( b_t == NULL ) {
+ info = LAPACK_TRANSPOSE_MEMORY_ERROR;
+ goto exit_level_1;
+ }
+ /* Transpose input matrices */
+ LAPACKE_dge_trans( matrix_order, m, n, a, lda, a_t, lda_t );
+ /* Call LAPACK function and adjust info */
+ LAPACK_zlacp2( &uplo, &m, &n, a_t, &lda_t, b_t, &ldb_t );
+ info = 0; /* LAPACK call is ok! */
+ /* Transpose output matrices */
+ LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, b_t, ldb_t, b, ldb );
+ /* Release memory and exit */
+ LAPACKE_free( b_t );
+exit_level_1:
+ LAPACKE_free( a_t );
+exit_level_0:
+ if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_zlacp2_work", info );
+ }
+ } else {
+ info = -1;
+ LAPACKE_xerbla( "LAPACKE_zlacp2_work", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_zstegr_work.c b/lapack-netlib/lapacke/src/lapacke_zstegr_work.c
index ad56b96c6..3ed189498 100644
--- a/lapack-netlib/lapacke/src/lapacke_zstegr_work.c
+++ b/lapack-netlib/lapacke/src/lapacke_zstegr_work.c
@@ -55,7 +55,7 @@ lapack_int LAPACKE_zstegr_work( int matrix_order, char jobz, char range,
lapack_int ldz_t = MAX(1,n);
lapack_complex_double* z_t = NULL;
/* Check leading dimension(s) */
- if( ldz < *m ) {
+ if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) {
info = -15;
LAPACKE_xerbla( "LAPACKE_zstegr_work", info );
return info;
diff --git a/lapack-netlib/lapacke/src/lapacke_zsysv_rook.c b/lapack-netlib/lapacke/src/lapacke_zsysv_rook.c
new file mode 100644
index 000000000..7db4d6476
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_zsysv_rook.c
@@ -0,0 +1,82 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 zsysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_zsysv_rook( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_double* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_double* b, lapack_int ldb )
+{
+ lapack_int info = 0;
+ lapack_int lwork = -1;
+ lapack_complex_double* work = NULL;
+ lapack_complex_double work_query;
+ if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) {
+ LAPACKE_xerbla( "LAPACKE_zsysv_rook", -1 );
+ return -1;
+ }
+#ifndef LAPACK_DISABLE_NAN_CHECK
+ /* Optionally check input matrices for NaNs */
+ if( LAPACKE_zsy_nancheck( matrix_order, uplo, n, a, lda ) ) {
+ return -5;
+ }
+ if( LAPACKE_zge_nancheck( matrix_order, n, nrhs, b, ldb ) ) {
+ return -8;
+ }
+#endif
+ /* Query optimal working array(s) size */
+ info = LAPACKE_zsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, &work_query, lwork );
+ if( info != 0 ) {
+ goto exit_level_0;
+ }
+ lwork = LAPACK_Z2INT( work_query );
+ /* Allocate memory for work arrays */
+ work = (lapack_complex_double*)
+ LAPACKE_malloc( sizeof(lapack_complex_double) * lwork );
+ if( work == NULL ) {
+ info = LAPACK_WORK_MEMORY_ERROR;
+ goto exit_level_0;
+ }
+ /* Call middle-level interface */
+ info = LAPACKE_zsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv,
+ b, ldb, work, lwork );
+ /* Release memory and exit */
+ LAPACKE_free( work );
+exit_level_0:
+ if( info == LAPACK_WORK_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_zsysv_rook", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/lapacke/src/lapacke_zsysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_zsysv_rook_work.c
new file mode 100644
index 000000000..249d924f0
--- /dev/null
+++ b/lapack-netlib/lapacke/src/lapacke_zsysv_rook_work.c
@@ -0,0 +1,112 @@
+/*****************************************************************************
+ Copyright (c) 2010, 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 zsysv_rook
+* Author: Intel Corporation
+* Generated January, 2012
+*****************************************************************************/
+
+#include "lapacke_utils.h"
+
+lapack_int LAPACKE_zsysv_rook_work( int matrix_order, char uplo, lapack_int n,
+ lapack_int nrhs, lapack_complex_double* a,
+ lapack_int lda, lapack_int* ipiv,
+ lapack_complex_double* b, lapack_int ldb,
+ lapack_complex_double* work,
+ lapack_int lwork )
+{
+ lapack_int info = 0;
+ if( matrix_order == LAPACK_COL_MAJOR ) {
+ /* Call LAPACK function and adjust info */
+ LAPACK_zsysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work,
+ &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ } else if( matrix_order == LAPACK_ROW_MAJOR ) {
+ lapack_int lda_t = MAX(1,n);
+ lapack_int ldb_t = MAX(1,n);
+ lapack_complex_double* a_t = NULL;
+ lapack_complex_double* b_t = NULL;
+ /* Check leading dimension(s) */
+ if( lda < n ) {
+ info = -6;
+ LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info );
+ return info;
+ }
+ if( ldb < nrhs ) {
+ info = -9;
+ LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info );
+ return info;
+ }
+ /* Query optimal working array(s) size if requested */
+ if( lwork == -1 ) {
+ LAPACK_zsysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t,
+ work, &lwork, &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;
+ }
+ b_t = (lapack_complex_double*)
+ LAPACKE_malloc( sizeof(lapack_complex_double) *
+ ldb_t * MAX(1,nrhs) );
+ if( b_t == NULL ) {
+ info = LAPACK_TRANSPOSE_MEMORY_ERROR;
+ goto exit_level_1;
+ }
+ /* Transpose input matrices */
+ LAPACKE_zsy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t );
+ LAPACKE_zge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t );
+ /* Call LAPACK function and adjust info */
+ LAPACK_zsysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t,
+ work, &lwork, &info );
+ if( info < 0 ) {
+ info = info - 1;
+ }
+ /* Transpose output matrices */
+ LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda );
+ LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb );
+ /* Release memory and exit */
+ LAPACKE_free( b_t );
+exit_level_1:
+ LAPACKE_free( a_t );
+exit_level_0:
+ if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
+ LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info );
+ }
+ } else {
+ info = -1;
+ LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info );
+ }
+ return info;
+}
diff --git a/lapack-netlib/make.inc.example b/lapack-netlib/make.inc.example
index 940e4c7ea..0f28d6bf6 100644
--- a/lapack-netlib/make.inc.example
+++ b/lapack-netlib/make.inc.example
@@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
-# LAPACK, Version 3.4.0 #
-# April 2012 #
+# LAPACK, Version 3.5.0 #
+# November 2013 #
####################################################################
#
SHELL = /bin/sh
@@ -13,9 +13,9 @@ SHELL = /bin/sh
# desired load options for your machine.
#
FORTRAN = gfortran
-OPTS = -O2
+OPTS = -O2 -frecursive
DRVOPTS = $(OPTS)
-NOOPT = -O0
+NOOPT = -O0 -frecursive
LOADER = gfortran
LOADOPTS =
#