Merge pull request #4322 from martin-frbg/lapack891

Add truncated QR with pivoting (Reference-LAPACK PR 891)

cmake/lapack.cmake

@@ -52,7 +52,7 @@ set(SLASRC
    sgebrd.f sgecon.f sgeequ.f sgees.f  sgeesx.f sgeev.f  sgeevx.f
    sgehd2.f sgehrd.f sgelq2.f sgelqf.f
    sgels.f  sgelsd.f sgelss.f sgelsy.f sgeql2.f sgeqlf.f
-   sgeqp3.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f
+   sgeqp3.f sgeqp3rk.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f
    sgesc2.f sgesdd.f sgesvd.f sgesvdx.f sgesvx.f sgetc2.f
    sgetrf2.f sgetri.f
    sggbak.f sggbal.f
@@ -67,7 +67,7 @@ set(SLASRC
    slangb.f slange.f slangt.f slanhs.f slansb.f slansp.f
    slansy.f slantb.f slantp.f slantr.f slanv2.f
    slapll.f slapmt.f
-   slaqgb.f slaqge.f slaqp2.f slaqps.f slaqsb.f slaqsp.f slaqsy.f
+   slaqgb.f slaqge.f slaqp2.f slaqps.f slaqp2rk.f slaqp3rk.f slaqsb.f slaqsp.f slaqsy.f
    slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f
    slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f
    slarf.f  slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f slargv.f
@@ -139,7 +139,7 @@ set(CLASRC
    cgbtf2.f cgbtrf.f cgbtrs.f cgebak.f cgebal.f cgebd2.f cgebrd.f
    cgecon.f cgeequ.f cgees.f  cgeesx.f cgeev.f  cgeevx.f
    cgehd2.f cgehrd.f cgelq2.f cgelqf.f
-   cgels.f  cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f cgeqp3.f
+   cgels.f  cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f cgeqp3.f cgeqp3rk.f
    cgeqr2.f cgeqr2p.f cgeqrf.f cgeqrfp.f cgerfs.f cgerq2.f cgerqf.f
    cgesc2.f cgesdd.f cgesvd.f cgesvdx.f
    cgesvj.f cgejsv.f cgsvj0.f cgsvj1.f
@@ -173,7 +173,7 @@ set(CLASRC
    clanhb.f clanhe.f
    clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f
    clantp.f clantr.f clapll.f clapmt.f clarcm.f claqgb.f claqge.f
-   claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqsb.f
+   claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqp2rk.f claqp3rk.f claqsb.f
    claqr0.f claqr1.f claqr2.f claqr3.f claqr4.f claqr5.f
    claqz0.f claqz1.f claqz2.f claqz3.f
    claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f
@@ -243,7 +243,7 @@ set(DLASRC
    dgebrd.f dgecon.f dgeequ.f dgees.f  dgeesx.f dgeev.f  dgeevx.f
    dgehd2.f dgehrd.f dgelq2.f dgelqf.f
    dgels.f  dgelsd.f dgelss.f dgelsy.f dgeql2.f dgeqlf.f
-   dgeqp3.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f
+   dgeqp3.f dgeqp3rk.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f
    dgesc2.f dgesdd.f dgesvd.f dgesvdx.f dgesvx.f dgetc2.f
    dgetrf2.f dgetri.f
    dggbak.f dggbal.f
@@ -258,7 +258,7 @@ set(DLASRC
    dlangb.f dlange.f dlangt.f dlanhs.f dlansb.f dlansp.f
    dlansy.f dlantb.f dlantp.f dlantr.f dlanv2.f
    dlapll.f dlapmt.f
-   dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f
+   dlaqgb.f dlaqge.f dlaqp2.f dlaqp2rk.f dlaqp3rk.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f
    dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f
    dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f
    dlarf.f  dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f
@@ -331,7 +331,7 @@ set(ZLASRC
    zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f zgebrd.f
    zgecon.f zgeequ.f zgees.f  zgeesx.f zgeev.f  zgeevx.f
    zgehd2.f zgehrd.f zgelq2.f zgelqf.f
-   zgels.f  zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f
+   zgels.f  zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f zgeqp3rk.f
    zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f
    zgesc2.f zgesdd.f zgesvd.f zgesvdx.f zgesvx.f
    zgesvj.f zgejsv.f zgsvj0.f zgsvj1.f
@@ -367,7 +367,7 @@ set(ZLASRC
    zlanhe.f
    zlanhp.f zlanhs.f zlanht.f zlansb.f zlansp.f zlansy.f zlantb.f
    zlantp.f zlantr.f zlapll.f zlapmt.f zlaqgb.f zlaqge.f
-   zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqsb.f
+   zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqp2rk.f zlaqp3rk.f zlaqps.f zlaqsb.f
    zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f
    zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f
    zlarcm.f zlarf.f  zlarfb.f zlarfb_gett.f
@@ -557,7 +557,7 @@ set(SLASRC
    sgebrd.c sgecon.c sgeequ.c sgees.c  sgeesx.c sgeev.c  sgeevx.c
    sgehd2.c sgehrd.c sgelq2.c sgelqf.c
    sgels.c  sgelsd.c sgelss.c sgelsy.c sgeql2.c sgeqlf.c
-   sgeqp3.c sgeqr2.c sgeqr2p.c sgeqrf.c sgeqrfp.c sgerfs.c sgerq2.c sgerqf.c
+   sgeqp3.c sgeqp3rk.c sgeqr2.c sgeqr2p.c sgeqrf.c sgeqrfp.c sgerfs.c sgerq2.c sgerqf.c
    sgesc2.c sgesdd.c sgesvd.c sgesvdx.c sgesvx.c sgetc2.c
    sgetrf2.c sgetri.c
    sggbak.c sggbal.c
@@ -571,7 +571,7 @@ set(SLASRC
    slangb.c slange.c slangt.c slanhs.c slansb.c slansp.c
    slansy.c slantb.c slantp.c slantr.c slanv2.c
    slapll.c slapmt.c
-   slaqgb.c slaqge.c slaqp2.c slaqps.c slaqsb.c slaqsp.c slaqsy.c
+   slaqgb.c slaqge.c slaqp2.c slaqp2rk.c slaqp3rk.c slaqps.c slaqsb.c slaqsp.c slaqsy.c
    slaqr0.c slaqr1.c slaqr2.c slaqr3.c slaqr4.c slaqr5.c
    slaqtr.c slar1v.c slar2v.c ilaslr.c ilaslc.c
    slarf.c  slarfb.c slarfb_gett.c slarfg.c slarfgp.c slarft.c slarfx.c slarfy.c slargv.c
@@ -643,7 +643,7 @@ set(CLASRC
    cgbtf2.c cgbtrf.c cgbtrs.c cgebak.c cgebal.c cgebd2.c cgebrd.c
    cgecon.c cgeequ.c cgees.c  cgeesx.c cgeev.c  cgeevx.c
    cgehd2.c cgehrd.c cgelq2.c cgelqf.c
-   cgels.c  cgelsd.c cgelss.c cgelsy.c cgeql2.c cgeqlf.c cgeqp3.c
+   cgels.c  cgelsd.c cgelss.c cgelsy.c cgeql2.c cgeqlf.c cgeqp3.c cgeqp3rk.c
    cgeqr2.c cgeqr2p.c cgeqrf.c cgeqrfp.c cgerfs.c cgerq2.c cgerqf.c
    cgesc2.c cgesdd.c cgesvd.c cgesvdx.c
    cgesvj.c cgejsv.c cgsvj0.c cgsvj1.c
@@ -677,7 +677,7 @@ set(CLASRC
    clanhb.c clanhe.c
    clanhp.c clanhs.c clanht.c clansb.c clansp.c clansy.c clantb.c
    clantp.c clantr.c clapll.c clapmt.c clarcm.c claqgb.c claqge.c
-   claqhb.c claqhe.c claqhp.c claqp2.c claqps.c claqsb.c
+   claqhb.c claqhe.c claqhp.c claqp2.c claqp2rk.c claqp3rk.c claqps.c claqsb.c
    claqr0.c claqr1.c claqr2.c claqr3.c claqr4.c claqr5.c
    claqsp.c claqsy.c clar1v.c clar2v.c ilaclr.c ilaclc.c
    clarf.c  clarfb.c clarfb_gett.c clarfg.c clarfgp.c clarft.c
@@ -746,7 +746,7 @@ set(DLASRC
    dgebrd.c dgecon.c dgeequ.c dgees.c  dgeesx.c dgeev.c  dgeevx.c
    dgehd2.c dgehrd.c dgelq2.c dgelqf.c
    dgels.c  dgelsd.c dgelss.c dgelsy.c dgeql2.c dgeqlf.c
-   dgeqp3.c dgeqr2.c dgeqr2p.c dgeqrf.c dgeqrfp.c dgerfs.c dgerq2.c dgerqf.c
+   dgeqp3.c dgeqp3rk.c dgeqr2.c dgeqr2p.c dgeqrf.c dgeqrfp.c dgerfs.c dgerq2.c dgerqf.c
    dgesc2.c dgesdd.c dgesvd.c dgesvdx.c dgesvx.c dgetc2.c
    dgetrf2.c dgetri.c
    dggbak.c dggbal.c
@@ -760,7 +760,7 @@ set(DLASRC
    dlangb.c dlange.c dlangt.c dlanhs.c dlansb.c dlansp.c
    dlansy.c dlantb.c dlantp.c dlantr.c dlanv2.c
    dlapll.c dlapmt.c
-   dlaqgb.c dlaqge.c dlaqp2.c dlaqps.c dlaqsb.c dlaqsp.c dlaqsy.c
+   dlaqgb.c dlaqge.c dlaqp2.c dlaqp2rk.c dlaqp3rk.c dlaqps.c dlaqsb.c dlaqsp.c dlaqsy.c
    dlaqr0.c dlaqr1.c dlaqr2.c dlaqr3.c dlaqr4.c dlaqr5.c
    dlaqtr.c dlar1v.c dlar2v.c iladlr.c iladlc.c
    dlarf.c  dlarfb.c dlarfb_gett.c dlarfg.c dlarfgp.c dlarft.c dlarfx.c dlarfy.c
@@ -833,7 +833,7 @@ set(ZLASRC
    zgbtf2.c zgbtrf.c zgbtrs.c zgebak.c zgebal.c zgebd2.c zgebrd.c
    zgecon.c zgeequ.c zgees.c  zgeesx.c zgeev.c  zgeevx.c
    zgehd2.c zgehrd.c zgelq2.c zgelqf.c
-   zgels.c  zgelsd.c zgelss.c zgelsy.c zgeql2.c zgeqlf.c zgeqp3.c
+   zgels.c  zgelsd.c zgelss.c zgelsy.c zgeql2.c zgeqlf.c zgeqp3.c zgeqp3rk.c
    zgeqr2.c zgeqr2p.c zgeqrf.c zgeqrfp.c zgerfs.c zgerq2.c zgerqf.c
    zgesc2.c zgesdd.c zgesvd.c zgesvdx.c zgesvx.c
    zgesvj.c zgejsv.c zgsvj0.c zgsvj1.c
@@ -868,7 +868,7 @@ set(ZLASRC
    zlanhe.c
    zlanhp.c zlanhs.c zlanht.c zlansb.c zlansp.c zlansy.c zlantb.c
    zlantp.c zlantr.c zlapll.c zlapmt.c zlaqgb.c zlaqge.c
-   zlaqhb.c zlaqhe.c zlaqhp.c zlaqp2.c zlaqps.c zlaqsb.c
+   zlaqhb.c zlaqhe.c zlaqhp.c zlaqp2.c zlaqp2rk.c zlaqp3rk.c zlaqps.c zlaqsb.c
    zlaqr0.c zlaqr1.c zlaqr2.c zlaqr3.c zlaqr4.c zlaqr5.c
    zlaqsp.c zlaqsy.c zlar1v.c zlar2v.c ilazlr.c ilazlc.c
    zlarcm.c zlarf.c  zlarfb.c zlarfb_gett.c

lapack-netlib/SRC/Makefile

@@ -136,7 +136,7 @@ SLASRC_O = \
    sgebrd.o sgecon.o sgeequ.o sgees.o  sgeesx.o sgeev.o  sgeevx.o \
    sgehd2.o sgehrd.o sgelq2.o sgelqf.o \
    sgels.o  sgelsd.o sgelss.o sgelsy.o sgeql2.o sgeqlf.o \
-   sgeqp3.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \
+   sgeqp3.o sgeqp3rk.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \
    sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o  sgesvd.o sgesvdx.o sgesvx.o \
    sgetc2.o sgetf2.o sgetri.o \
    sggbak.o sggbal.o sgges.o  sgges3.o sggesx.o \
@@ -151,7 +151,7 @@ SLASRC_O = \
    slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \
    slansy.o slantb.o slantp.o slantr.o slanv2.o \
    slapll.o slapmt.o \
-   slaqgb.o slaqge.o slaqp2.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \
+   slaqgb.o slaqge.o slaqp2.o slaqp2rk.o slaqp3rk.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \
    slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \
    slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
    slarf.o  slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o slargv.o \
@@ -232,7 +232,7 @@ CLASRC_O = \
    cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \
    cgecon.o cgeequ.o cgees.o  cgeesx.o cgeev.o  cgeevx.o \
    cgehd2.o cgehrd.o cgelq2.o cgelqf.o \
-   cgels.o  cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o \
+   cgels.o  cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o cgeqp3rk.o \
    cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \
    cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o  cgesvd.o  cgesvdx.o \
    cgesvj.o cgejsv.o cgsvj0.o cgsvj1.o \
@@ -266,7 +266,7 @@ CLASRC_O = \
    clanhb.o clanhe.o \
    clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \
    clantp.o clantr.o clapll.o clapmt.o clarcm.o claqgb.o claqge.o \
-   claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqsb.o \
+   claqhb.o claqhe.o claqhp.o claqp2.o claqp2rk.o claqp3rk.o claqps.o claqsb.o \
    claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \
    claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \
    claqz0.o claqz1.o claqz2.o claqz3.o \
@@ -345,7 +345,7 @@ DLASRC_O = \
    dgebrd.o dgecon.o dgeequ.o dgees.o  dgeesx.o dgeev.o  dgeevx.o \
    dgehd2.o dgehrd.o dgelq2.o dgelqf.o \
    dgels.o  dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \
-   dgeqp3.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \
+   dgeqp3.o dgeqp3rk.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \
    dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o  dgesvd.o dgesvdx.o dgesvx.o \
    dgetc2.o dgetf2.o dgetrf.o dgetri.o \
    dgetrs.o dggbak.o dggbal.o dgges.o  dgges3.o dggesx.o \
@@ -360,7 +360,7 @@ DLASRC_O = \
    dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \
    dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \
    dlapll.o dlapmt.o \
-   dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \
+   dlaqgb.o dlaqge.o dlaqp2.o dlaqp2rk.o dlaqp3rk.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \
    dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \
    dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
    dlarf.o  dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \
@@ -437,7 +437,7 @@ ZLASRC_O = \
    zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \
    zgecon.o zgeequ.o zgees.o  zgeesx.o zgeev.o  zgeevx.o \
    zgehd2.o zgehrd.o zgelq2.o zgelqf.o \
-   zgels.o  zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o \
+   zgels.o  zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o zgeqp3rk.o \
    zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \
    zgesc2.o zgesdd.o zgesv.o  zgesvd.o zgesvdx.o \
    zgesvj.o zgejsv.o zgsvj0.o zgsvj1.o \
@@ -473,7 +473,7 @@ ZLASRC_O = \
    zlanhe.o \
    zlanhp.o zlanhs.o zlanht.o zlansb.o zlansp.o zlansy.o zlantb.o \
    zlantp.o zlantr.o zlapll.o zlapmt.o zlaqgb.o zlaqge.o \
-   zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqsb.o \
+   zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqp2rk.o zlaqp3rk.o zlaqps.o zlaqsb.o \
    zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \
    zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \
    zlaqz0.o zlaqz1.o zlaqz2.o zlaqz3.o \

lapack-netlib/SRC/claqp2rk.c

@@ -0,0 +1,943 @@
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) {ceil(w)}
+#define myhuge_(w) {HUGE_VAL}
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+	complex pow={1.0,0.0}; unsigned long int u;
+		if(n != 0) {
+		if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+		for(u = n; ; ) {
+			if(u & 01) pow.r *= x.r, pow.i *= x.i;
+			if(u >>= 1) x.r *= x.r, x.i *= x.i;
+			else break;
+		}
+	}
+	_Fcomplex p={pow.r, pow.i};
+	return p;
+}
+#else
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+	_Dcomplex pow={1.0,0.0}; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+		for(u = n; ; ) {
+			if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+			if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+			else break;
+		}
+	}
+	_Dcomplex p = {pow._Val[0], pow._Val[1]};
+	return p;
+}
+#else
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int claqp2rk_(integer *m, integer *n, integer *nrhs, integer 
+	*ioffset, integer *kmax, real *abstol, real *reltol, integer *kp1, 
+	real *maxc2nrm, complex *a, integer *lda, integer *k, real *maxc2nrmk,
+	 real *relmaxc2nrmk, integer *jpiv, complex *tau, real *vn1, real *
+	vn2, complex *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1;
+    complex q__1;
+
+    /* Local variables */
+    complex aikk;
+    real temp, temp2;
+    integer i__, j;
+    real tol3z;
+    integer jmaxc2nrm;
+    extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+	    , integer *, complex *, complex *, integer *, complex *), 
+	    cswap_(integer *, complex *, integer *, complex *, integer *);
+    integer itemp, minmnfact;
+    real myhugeval;
+    integer minmnupdt;
+    extern real scnrm2_(integer *, complex *, integer *);
+    integer kk, kp;
+    extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, 
+	    integer *, complex *);
+    extern real slamch_(char *);
+    extern integer isamax_(integer *, real *, integer *);
+    real taunan;
+    extern logical sisnan_(real *);
+
+
+/*  -- LAPACK auxiliary routine -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/*  ===================================================================== */
+
+
+/*     Initialize INFO */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpiv;
+    --tau;
+    --vn1;
+    --vn2;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+
+/*     MINMNFACT in the smallest dimension of the submatrix */
+/*     A(IOFFSET+1:M,1:N) to be factorized. */
+
+/*     MINMNUPDT is the smallest dimension */
+/*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which */
+/*     contains the submatrices A(IOFFSET+1:M,1:N) and */
+/*     B(IOFFSET+1:M,1:NRHS) as column blocks. */
+
+/* Computing MIN */
+    i__1 = *m - *ioffset;
+    minmnfact = f2cmin(i__1,*n);
+/* Computing MIN */
+    i__1 = *m - *ioffset, i__2 = *n + *nrhs;
+    minmnupdt = f2cmin(i__1,i__2);
+    *kmax = f2cmin(*kmax,minmnfact);
+    tol3z = sqrt(slamch_("Epsilon"));
+    myhugeval = slamch_("Overflow");
+
+/*     Compute the factorization, KK is the lomn loop index. */
+
+    i__1 = *kmax;
+    for (kk = 1; kk <= i__1; ++kk) {
+
+	i__ = *ioffset + kk;
+
+	if (i__ == 1) {
+
+/*           ============================================================ */
+
+/*           We are at the first column of the original whole matrix A, */
+/*           therefore we use the computed KP1 and MAXC2NRM from the */
+/*           main routine. */
+
+	    kp = *kp1;
+
+/*           ============================================================ */
+
+	} else {
+
+/*           ============================================================ */
+
+/*           Determine the pivot column in KK-th step, i.e. the index */
+/*           of the column with the maximum 2-norm in the */
+/*           submatrix A(I:M,K:N). */
+
+	    i__2 = *n - kk + 1;
+	    kp = kk - 1 + isamax_(&i__2, &vn1[kk], &c__1);
+
+/*           Determine the maximum column 2-norm and the relative maximum */
+/*           column 2-norm of the submatrix A(I:M,KK:N) in step KK. */
+/*           RELMAXC2NRMK  will be computed later, after somecondition */
+/*           checks on MAXC2NRMK. */
+
+	    *maxc2nrmk = vn1[kp];
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains NaN, and set */
+/*           INFO parameter to the column number, where the first NaN */
+/*           is found and return from the routine. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (sisnan_(maxc2nrmk)) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*info = *k + kp;
+
+/*               Set RELMAXC2NRMK to NaN. */
+
+		*relmaxc2nrmk = *maxc2nrmk;
+
+/*               Array TAU(K+1:MINMNFACT) is not set and contains */
+/*               undefined elements. */
+
+		return 0;
+	    }
+
+/*           ============================================================ */
+
+/*           Quick return, if the submatrix A(I:M,KK:N) is */
+/*           a zero matrix. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*maxc2nrmk == 0.f) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*relmaxc2nrmk = 0.f;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    i__3 = j;
+		    tau[i__3].r = 0.f, tau[i__3].i = 0.f;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains Inf, */
+/*           set INFO parameter to the column number, where */
+/*           the first Inf is found plus N, and continue */
+/*           the computation. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*info == 0 && *maxc2nrmk > myhugeval) {
+		*info = *n + kk - 1 + kp;
+	    }
+
+/*           ============================================================ */
+
+/*           Test for the second and third stopping criteria. */
+/*           NOTE: There is no need to test for ABSTOL >= ZERO, since */
+/*           MAXC2NRMK is non-negative. Similarly, there is no need */
+/*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is */
+/*           non-negative. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+
+	    if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) {
+
+/*              Set K, the number of factorized columns. */
+
+		*k = kk - 1;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    i__3 = j;
+		    tau[i__3].r = 0.f, tau[i__3].i = 0.f;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           End ELSE of IF(I.EQ.1) */
+
+	}
+
+/*        =============================================================== */
+
+/*        If the pivot column is not the first column of the */
+/*        subblock A(1:M,KK:N): */
+/*        1) swap the KK-th column and the KP-th pivot column */
+/*           in A(1:M,1:N); */
+/*        2) copy the KK-th element into the KP-th element of the partial */
+/*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */
+/*           for VN1 and VN2 since we use the element with the index */
+/*           larger than KK in the next loop step.) */
+/*        3) Save the pivot interchange with the indices relative to the */
+/*           the original matrix A, not the block A(1:M,1:N). */
+
+	if (kp != kk) {
+	    cswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1);
+	    vn1[kp] = vn1[kk];
+	    vn2[kp] = vn2[kk];
+	    itemp = jpiv[kp];
+	    jpiv[kp] = jpiv[kk];
+	    jpiv[kk] = itemp;
+	}
+
+/*        Generate elementary reflector H(KK) using the column A(I:M,KK), */
+/*        if the column has more than one element, otherwise */
+/*        the elementary reflector would be an identity matrix, */
+/*        and TAU(KK) = CZERO. */
+
+	if (i__ < *m) {
+	    i__2 = *m - i__ + 1;
+	    clarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], &
+		    c__1, &tau[kk]);
+	} else {
+	    i__2 = kk;
+	    tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+	}
+
+/*        Check if TAU(KK) contains NaN, set INFO parameter */
+/*        to the column number where NaN is found and return from */
+/*        the routine. */
+/*        NOTE: There is no need to check TAU(KK) for Inf, */
+/*        since CLARFG cannot produce TAU(KK) or Householder vector */
+/*        below the diagonal containing Inf. Only BETA on the diagonal, */
+/*        returned by CLARFG can contain Inf, which requires */
+/*        TAU(KK) to contain NaN. Therefore, this case of generating Inf */
+/*        by CLARFG is covered by checking TAU(KK) for NaN. */
+
+	i__2 = kk;
+	r__1 = tau[i__2].r;
+	if (sisnan_(&r__1)) {
+	    i__2 = kk;
+	    taunan = tau[i__2].r;
+	} else /* if(complicated condition) */ {
+	    r__1 = r_imag(&tau[kk]);
+	    if (sisnan_(&r__1)) {
+		taunan = r_imag(&tau[kk]);
+	    } else {
+		taunan = 0.f;
+	    }
+	}
+
+	if (sisnan_(&taunan)) {
+	    *k = kk - 1;
+	    *info = kk;
+
+/*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN. */
+
+	    *maxc2nrmk = taunan;
+	    *relmaxc2nrmk = taunan;
+
+/*           Array TAU(KK:MINMNFACT) is not set and contains */
+/*           undefined elements, except the first element TAU(KK) = NaN. */
+
+	    return 0;
+	}
+
+/*        Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. */
+/*        ( If M >= N, then at KK = N there is no residual matrix, */
+/*         i.e. no columns of A to update, only columns of B. */
+/*         If M < N, then at KK = M-IOFFSET, I = M and we have a */
+/*         one-row residual matrix in A and the elementary */
+/*         reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update */
+/*         is needed for the residual matrix in A and the */
+/*         right-hand-side-matrix in B. */
+/*         Therefore, we update only if */
+/*         KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */
+/*         condition is satisfied, not only KK < N+NRHS ) */
+
+	if (kk < minmnupdt) {
+	    i__2 = i__ + kk * a_dim1;
+	    aikk.r = a[i__2].r, aikk.i = a[i__2].i;
+	    i__2 = i__ + kk * a_dim1;
+	    a[i__2].r = 1.f, a[i__2].i = 0.f;
+	    i__2 = *m - i__ + 1;
+	    i__3 = *n + *nrhs - kk;
+	    r_cnjg(&q__1, &tau[kk]);
+	    clarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &q__1, 
+		    &a[i__ + (kk + 1) * a_dim1], lda, &work[1]);
+	    i__2 = i__ + kk * a_dim1;
+	    a[i__2].r = aikk.r, a[i__2].i = aikk.i;
+	}
+
+	if (kk < minmnfact) {
+
+/*           Update the partial column 2-norms for the residual matrix, */
+/*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */
+/*           when KK < f2cmin(M-IOFFSET, N). */
+
+	    i__2 = *n;
+	    for (j = kk + 1; j <= i__2; ++j) {
+		if (vn1[j] != 0.f) {
+
+/*                 NOTE: The following lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+/* Computing 2nd power */
+		    r__1 = c_abs(&a[i__ + j * a_dim1]) / vn1[j];
+		    temp = 1.f - r__1 * r__1;
+		    temp = f2cmax(temp,0.f);
+/* Computing 2nd power */
+		    r__1 = vn1[j] / vn2[j];
+		    temp2 = temp * (r__1 * r__1);
+		    if (temp2 <= tol3z) {
+
+/*                    Compute the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by explicitly computing it, */
+/*                    and store it in both partial 2-norm vector VN1 */
+/*                    and exact column 2-norm vector VN2. */
+
+			i__3 = *m - i__;
+			vn1[j] = scnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], &
+				c__1);
+			vn2[j] = vn1[j];
+
+		    } else {
+
+/*                    Update the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by removing one */
+/*                    element A(I,J) and store it in partial */
+/*                    2-norm vector VN1. */
+
+			vn1[j] *= sqrt(temp);
+
+		    }
+		}
+	    }
+
+	}
+
+/*     End factorization loop */
+
+    }
+
+/*     If we reached this point, all colunms have been factorized, */
+/*     i.e. no condition was triggered to exit the routine. */
+/*     Set the number of factorized columns. */
+
+    *k = *kmax;
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */
+/*     we return. */
+
+    if (*k < minmnfact) {
+
+	i__1 = *n - *k;
+	jmaxc2nrm = *k + isamax_(&i__1, &vn1[*k + 1], &c__1);
+	*maxc2nrmk = vn1[jmaxc2nrm];
+
+	if (*k == 0) {
+	    *relmaxc2nrmk = 1.f;
+	} else {
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+	}
+
+    } else {
+	*maxc2nrmk = 0.f;
+	*relmaxc2nrmk = 0.f;
+    }
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, set TAUs corresponding to the columns that were */
+/*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. */
+
+    i__1 = minmnfact;
+    for (j = *k + 1; j <= i__1; ++j) {
+	i__2 = j;
+	tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+    }
+
+    return 0;
+
+/*     End of CLAQP2RK */
+
+} /* claqp2rk_ */
+

lapack-netlib/SRC/claqp2rk.f

@@ -0,0 +1,726 @@
+*> \brief \b CLAQP2RK computes truncated QR factorization with column pivoting of a complex matrix block using Level 2 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CLAQP2RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/claqp2rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/claqp2rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/claqp2rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+*     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+*     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+*     $                     INFO )
+*      IMPLICIT NONE
+*
+*     .. Scalar Arguments ..
+*      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+*      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            JPIV( * )
+*      REAL               VN1( * ), VN2( * )
+*      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
+*     $
+*       ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> CLAQP2RK computes a truncated (rank K) or full rank Householder QR
+*> factorization with column pivoting of the complex matrix
+*> block A(IOFFSET+1:M,1:N) as
+*>
+*>   A * P(K) = Q(K) * R(K).
+*>
+*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N)
+*> is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides matrix block B
+*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**H * B.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] KMAX
+*> \verbatim
+*>          KMAX is INTEGER
+*>
+*>          The first factorization stopping criterion. KMAX >= 0.
+*>
+*>          The maximum number of columns of the matrix A to factorize,
+*>          i.e. the maximum factorization rank.
+*>
+*>          a) If KMAX >= min(M-IOFFSET,N), then this stopping
+*>                criterion is not used, factorize columns
+*>                depending on ABSTOL and RELTOL.
+*>
+*>          b) If KMAX = 0, then this stopping criterion is
+*>             satisfied on input and the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is REAL, cannot be NaN.
+*>
+*>          The second factorization stopping criterion.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is REAL, cannot be NaN.
+*>
+*>          The third factorization stopping criterion.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine CGEQP3RK. 1 <= KP1 <= N_orig_mat.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is REAL
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine CGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is COMPLEX array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:K) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(K) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:K) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,K+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(K)**H.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] K
+*> \verbatim
+*>          K is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N).
+*>
+*>          K also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is REAL
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank K. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is REAL
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank K) to the maximum column 2-norm of the
+*>          whole original matrix A. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is COMPLEX array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is REAL array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is REAL array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is COMPLEX array, dimension (N-1)
+*>          Used in CLARF subroutine to apply an elementary
+*>          reflector from the left.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step K+1 ( when K columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             K                  is set to the number of
+*>                                   factorized columns without
+*>                                   exception.
+*>             MAXC2NRMK          is set to NaN.
+*>             RELMAXC2NRMK       is set to NaN.
+*>             TAU(K+1:min(M,N))  is not set and contains undefined
+*>                                   elements. If j_1=K+1, TAU(K+1)
+*>                                   may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the factorization
+*>             step K+1 ( when K columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp2rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+     $                     INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPIV( * )
+      REAL               VN1( * ), VN2( * )
+      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. 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, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
+     $                   MINMNUPDT
+      REAL               HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z
+      COMPLEX            AIKK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, CLARFG, CSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, REAL, CONJG, IMAG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            SISNAN
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SCNRM2
+      EXTERNAL           SISNAN, SLAMCH, ISAMAX, SCNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+*     MINMNUPDT is the smallest dimension
+*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which
+*     contains the submatrices A(IOFFSET+1:M,1:N) and
+*     B(IOFFSET+1:M,1:NRHS) as column blocks.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      KMAX = MIN( KMAX, MINMNFACT )
+      TOL3Z = SQRT( SLAMCH( 'Epsilon' ) )
+      HUGEVAL = SLAMCH( 'Overflow' )
+*
+*     Compute the factorization, KK is the lomn loop index.
+*
+      DO KK = 1, KMAX
+*
+         I = IOFFSET + KK
+*
+         IF( I.EQ.1 ) THEN
+*
+*           ============================================================
+*
+*           We are at the first column of the original whole matrix A,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+            KP = KP1
+*
+*           ============================================================
+*
+         ELSE
+*
+*           ============================================================
+*
+*           Determine the pivot column in KK-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( KK-1 ) + ISAMAX( N-KK+1, VN1( KK ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,KK:N) in step KK.
+*           RELMAXC2NRMK  will be computed later, after somecondition
+*           checks on MAXC2NRMK.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains NaN, and set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( SISNAN( MAXC2NRMK ) ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+                K = KK - 1
+                INFO = K + KP
+*
+*               Set RELMAXC2NRMK to NaN.
+*
+                RELMAXC2NRMK = MAXC2NRMK
+*
+*               Array TAU(K+1:MINMNFACT) is not set and contains
+*               undefined elements.
+*
+               RETURN
+            END IF
+*
+*           ============================================================
+*
+*           Quick return, if the submatrix A(I:M,KK:N) is
+*           a zero matrix.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+               K = KK - 1
+               RELMAXC2NRMK = ZERO
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + KK - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third stopping criteria.
+*           NOTE: There is no need to test for ABSTOL >= ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+*              Set K, the number of factorized columns.
+*
+               K = KK - 1
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,KK:N):
+*        1) swap the KK-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) copy the KK-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than KK in the next loop step.)
+*        3) Save the pivot interchange with the indices relative to the
+*           the original matrix A, not the block A(1:M,1:N).
+*
+         IF( KP.NE.KK ) THEN
+            CALL CSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 )
+            VN1( KP ) = VN1( KK )
+            VN2( KP ) = VN2( KK )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( KK )
+            JPIV( KK ) = ITEMP
+         END IF
+*
+*        Generate elementary reflector H(KK) using the column A(I:M,KK),
+*        if the column has more than one element, otherwise
+*        the elementary reflector would be an identity matrix,
+*        and TAU(KK) = CZERO.
+*
+         IF( I.LT.M ) THEN
+            CALL CLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1,
+     $                   TAU( KK ) )
+         ELSE
+            TAU( KK ) = CZERO
+         END IF
+*
+*        Check if TAU(KK) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(KK) for Inf,
+*        since CLARFG cannot produce TAU(KK) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by CLARFG can contain Inf, which requires
+*        TAU(KK) to contain NaN. Therefore, this case of generating Inf
+*        by CLARFG is covered by checking TAU(KK) for NaN.
+*
+         IF( SISNAN( REAL( TAU(KK) ) ) ) THEN
+            TAUNAN = REAL( TAU(KK) )
+         ELSE IF( SISNAN( IMAG( TAU(KK) ) ) ) THEN
+            TAUNAN = IMAG( TAU(KK) )
+         ELSE
+            TAUNAN = ZERO
+         END IF
+*
+         IF( SISNAN( TAUNAN ) ) THEN
+            K = KK - 1
+            INFO = KK
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAUNAN
+            RELMAXC2NRMK = TAUNAN
+*
+*           Array TAU(KK:MINMNFACT) is not set and contains
+*           undefined elements, except the first element TAU(KK) = NaN.
+*
+            RETURN
+         END IF
+*
+*        Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left.
+*        ( If M >= N, then at KK = N there is no residual matrix,
+*         i.e. no columns of A to update, only columns of B.
+*         If M < N, then at KK = M-IOFFSET, I = M and we have a
+*         one-row residual matrix in A and the elementary
+*         reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update
+*         is needed for the residual matrix in A and the
+*         right-hand-side-matrix in B.
+*         Therefore, we update only if
+*         KK < MINMNUPDT = min(M-IOFFSET, N+NRHS)
+*         condition is satisfied, not only KK < N+NRHS )
+*
+         IF( KK.LT.MINMNUPDT ) THEN
+            AIKK = A( I, KK )
+            A( I, KK ) = CONE
+            CALL CLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+     $                  CONJG( TAU( KK ) ), A( I, KK+1 ), LDA,
+     $                  WORK( 1 ) )
+            A( I, KK ) = AIKK
+         END IF
+*
+         IF( KK.LT.MINMNFACT ) THEN
+*
+*           Update the partial column 2-norms for the residual matrix,
+*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e.
+*           when KK < min(M-IOFFSET, N).
+*
+            DO J = KK + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2
+                  TEMP = MAX( TEMP, ZERO )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN
+*
+*                    Compute the column 2-norm for the partial
+*                    column A(I+1:M,J) by explicitly computing it,
+*                    and store it in both partial 2-norm vector VN1
+*                    and exact column 2-norm vector VN2.
+*
+                     VN1( J ) = SCNRM2( M-I, A( I+1, J ), 1 )
+                     VN2( J ) = VN1( J )
+*
+                  ELSE
+*
+*                    Update the column 2-norm for the partial
+*                    column A(I+1:M,J) by removing one
+*                    element A(I,J) and store it in partial
+*                    2-norm vector VN1.
+*
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+*
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*     End factorization loop
+*
+      END DO
+*
+*     If we reached this point, all colunms have been factorized,
+*     i.e. no condition was triggered to exit the routine.
+*     Set the number of factorized columns.
+*
+      K = KMAX
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
+*     we return.
+*
+      IF( K.LT.MINMNFACT ) THEN
+*
+         JMAXC2NRM = K + ISAMAX( N-K, VN1( K+1 ), 1 )
+         MAXC2NRMK = VN1( JMAXC2NRM )
+*
+         IF( K.EQ.0 ) THEN
+            RELMAXC2NRMK = ONE
+         ELSE
+            RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM
+         END IF
+*
+      ELSE
+         MAXC2NRMK = ZERO
+         RELMAXC2NRMK = ZERO
+      END IF
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, set TAUs corresponding to the columns that were
+*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO.
+*
+      DO J = K + 1, MINMNFACT
+         TAU( J ) = CZERO
+      END DO
+*
+      RETURN
+*
+*     End of CLAQP2RK
+*
+      END

lapack-netlib/SRC/claqp3rk.f

@@ -0,0 +1,947 @@
+*> \brief \b CLAQP3RK computes a step of truncated QR factorization with column pivoting of a complex m-by-n matrix A using Level 3 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CLAQP3RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/claqp3rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/claqp3rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/claqp3rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE CLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+*     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+*     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+*     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+*      IMPLICIT NONE
+*      LOGICAL            DONE
+*      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+*     $                   NB, NRHS
+*      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            IWORK( * ), JPIV( * )
+*      REAL               VN1( * ), VN2( * )
+*      COMPLEX*16         A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
+*     ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> CLAQP3RK computes a step of truncated QR factorization with column
+*> pivoting of a complex M-by-N matrix A block A(IOFFSET+1:M,1:N)
+*> by using Level 3 BLAS as
+*>
+*>   A * P(KB) = Q(KB) * R(KB).
+*>
+*> The routine tries to factorize NB columns from A starting from
+*> the row IOFFSET+1 and updates the residual matrix with BLAS 3
+*> xGEMM. The number of actually factorized columns is returned
+*> is smaller than NB.
+*>
+*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides B matrix stored
+*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**H * B.
+*>
+*> Cases when the number of factorized columns KB < NB:
+*>
+*> (1) In some cases, due to catastrophic cancellations, it cannot
+*> factorize all NB columns and need to update the residual matrix.
+*> Hence, the actual number of factorized columns in the block returned
+*> in KB is smaller than NB. The logical DONE is returned as FALSE.
+*> The factorization of the whole original matrix A_orig must proceed
+*> with the next block.
+*>
+*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB.
+*>
+*> (3) In case both stopping criteria ABSTOL or RELTOL are not used,
+*> and when the residual matrix is a zero matrix in some factorization
+*> step KB, the factorization of the whole original matrix A_orig is
+*> stopped, the logical DONE is returned as TRUE. The number of
+*> factorized columns which is smaller than NB is returned in KB.
+*>
+*> (4) Whenever NaN is detected in the matrix A or in the array TAU,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB. The INFO
+*> parameter is set to the column index of the first NaN occurrence.
+*>
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*>          NB is INTEGER
+*>          Factorization block size, i.e the number of columns
+*>          to factorize in the matrix A. 0 <= NB
+*>
+*>          If NB = 0, then the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is REAL, cannot be NaN.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is REAL, cannot be NaN.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine CGEQP3RK. 1 <= KP1 <= N_orig.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is REAL
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine CGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is COMPLEX array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:KB) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(KB) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:KB) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,KB+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(KB)**H.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out]
+*> \verbatim
+*>          DONE is LOGICAL
+*>          TRUE: a) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to ABSTOL
+*>                   or RELTOL criterion,
+*>                b) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to the
+*>                   residual matrix being a ZERO matrix.
+*>                c) when NaN was detected in the matrix A
+*>                   or in the array TAU.
+*>          FALSE: otherwise.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*>          KB is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R.  0 <= KB <= min(M-IOFFSET,NB,N).
+*>
+*>          KB also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is REAL
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank KB. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is REAL
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank KB) to the maximum column 2-norm of the
+*>          original matrix A_orig. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is COMPLEX array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is REAL array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is REAL array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] AUXV
+*> \verbatim
+*>          AUXV is COMPLEX array, dimension (NB)
+*>          Auxiliary vector.
+*> \endverbatim
+*>
+*> \param[out] F
+*> \verbatim
+*>          F is COMPLEX array, dimension (LDF,NB)
+*>          Matrix F**H = L*(Y**H)*A.
+*> \endverbatim
+*>
+*> \param[in] LDF
+*> \verbatim
+*>          LDF is INTEGER
+*>          The leading dimension of the array F. LDF >= max(1,N+NRHS).
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*>          IWORK is INTEGER array, dimension (N-1).
+*>          Is a work array. ( IWORK is used to store indices
+*>          of "bad" columns for norm downdating in the residual
+*>          matrix ).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step KB+1 ( when KB columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             KB                  is set to the number of
+*>                                    factorized columns without
+*>                                    exception.
+*>             MAXC2NRMK           is set to NaN.
+*>             RELMAXC2NRMK        is set to NaN.
+*>             TAU(KB+1:min(M,N))     is not set and contains undefined
+*>                                    elements. If j_1=KB+1, TAU(KB+1)
+*>                                    may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the actorization
+*>             step KB+1 ( when KB columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp3rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE CLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      LOGICAL            DONE
+      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+     $                   NB, NRHS
+      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * ), JPIV( * )
+      REAL               VN1( * ), VN2( * )
+      COMPLEX            A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. 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            ITEMP, J, K, MINMNFACT, MINMNUPDT,
+     $                   LSTICC, KP, I, IF
+      REAL               HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z
+      COMPLEX            AIK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CGEMV, CLARFG, CSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, REAL, CONJG, IMAG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            SISNAN
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SCNRM2
+      EXTERNAL           SISNAN, SLAMCH, ISAMAX, SCNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      NB = MIN( NB, MINMNFACT )
+      TOL3Z = SQRT( SLAMCH( 'Epsilon' ) )
+      HUGEVAL = SLAMCH( 'Overflow' )
+*
+*     Compute factorization in a while loop over NB columns,
+*     K is the column index in the block A(1:M,1:N).
+*
+      K = 0
+      LSTICC = 0
+      DONE = .FALSE.
+*
+      DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 )
+         K = K + 1
+         I = IOFFSET + K
+*
+         IF( I.EQ.1 ) THEN
+*
+*           We are at the first column of the original whole matrix A_orig,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+            KP = KP1
+*
+         ELSE
+*
+*           Determine the pivot column in K-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,K:N) in step K.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains NaN, set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( SISNAN( MAXC2NRMK ) ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               INFO = KB + KP
+*
+*              Set RELMAXC2NRMK to NaN.
+*
+               RELMAXC2NRMK = MAXC2NRMK
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix contains NaN and we stop
+*              the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H.
+
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                  M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Array TAU(KF+1:MINMNFACT) is not set and contains
+*              undefined elements.
+*
+*              Return from the routine.
+*
+               RETURN
+            END IF
+*
+*           Quick return, if the submatrix A(I:M,K:N) is
+*           a zero matrix. We need to check it only if the column index
+*           (same as row index) is larger than 1, since the condition
+*           for the whole original matrix A_orig is checked in the main
+*           routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               RELMAXC2NRMK = ZERO
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix is zero and we stop the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H.
+*
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                  M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = CZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + K - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third tolerance stopping criteria.
+*           NOTE: There is no need to test for ABSTOL.GE.ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig;
+*
+                  KB = K - 1
+                  IF = I - 1
+*
+*              Apply the block reflector to the residual of the
+*              matrix A and the residual of the right hand sides B, if
+*              the residual matrix and and/or the residual of the right
+*              hand sides exist,  i.e. if the submatrix
+*              A(I+1:M,KB+1:N+NRHS) exists.  This occurs when
+*                 KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*              A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                             A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H.
+*
+               IF( KB.LT.MINMNUPDT ) THEN
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                  M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA,
+     $                  F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = CZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,K:N):
+*        1) swap the K-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) swap the K-th row and the KP-th row in F(1:N,1:K-1)
+*        3) copy the K-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. (Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than K in the next loop step.)
+*        4) Save the pivot interchange with the indices relative to the
+*           the original matrix A_orig, not the block A(1:M,1:N).
+*
+         IF( KP.NE.K ) THEN
+            CALL CSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 )
+            CALL CSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF )
+            VN1( KP ) = VN1( K )
+            VN2( KP ) = VN2( K )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( K )
+            JPIV( K ) = ITEMP
+         END IF
+*
+*        Apply previous Householder reflectors to column K:
+*        A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H.
+*
+         IF( K.GT.1 ) THEN
+            DO J = 1, K - 1
+               F( K, J ) = CONJG( F( K, J ) )
+            END DO
+            CALL CGEMV( 'No transpose', M-I+1, K-1, -CONE, A( I, 1 ),
+     $                  LDA, F( K, 1 ), LDF, CONE, A( I, K ), 1 )
+            DO J = 1, K - 1
+               F( K, J ) = CONJG( F( K, J ) )
+            END DO
+         END IF
+*
+*        Generate elementary reflector H(k) using the column A(I:M,K).
+*
+         IF( I.LT.M ) THEN
+            CALL CLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) )
+         ELSE
+            TAU( K ) = CZERO
+         END IF
+*
+*        Check if TAU(K) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(K) for Inf,
+*        since CLARFG cannot produce TAU(KK) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by CLARFG can contain Inf, which requires
+*        TAU(K) to contain NaN. Therefore, this case of generating Inf
+*        by CLARFG is covered by checking TAU(K) for NaN.
+*
+         IF( SISNAN( REAL( TAU(K) ) ) ) THEN
+            TAUNAN = REAL( TAU(K) )
+         ELSE IF( SISNAN( IMAG( TAU(K) ) ) ) THEN
+            TAUNAN = IMAG( TAU(K) )
+         ELSE
+            TAUNAN = ZERO
+         END IF
+*
+         IF( SISNAN( TAUNAN ) ) THEN
+*
+            DONE = .TRUE.
+*
+*           Set KB, the number of factorized partial columns
+*                   that are non-zero in each step in the block,
+*                   i.e. the rank of the factor R.
+*           Set IF, the number of processed rows in the block, which
+*                   is the same as the number of processed rows in
+*                   the original whole matrix A_orig.
+*
+            KB = K - 1
+            IF = I - 1
+            INFO = K
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAUNAN
+            RELMAXC2NRMK = TAUNAN
+*
+*           There is no need to apply the block reflector to the
+*           residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*           since the submatrix contains NaN and we stop
+*           the computation.
+*           But, we need to apply the block reflector to the residual
+*           right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*           residual right hand sides exist.  This occurs
+*           when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*           A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                            A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H.
+*
+            IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+               CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $               M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA,
+     $               F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA )
+            END IF
+*
+*           There is no need to recompute the 2-norm of the
+*           difficult columns, since we stop the factorization.
+*
+*           Array TAU(KF+1:MINMNFACT) is not set and contains
+*           undefined elements.
+*
+*           Return from the routine.
+*
+            RETURN
+         END IF
+*
+*        ===============================================================
+*
+         AIK = A( I, K )
+         A( I, K ) = CONE
+*
+*        ===============================================================
+*
+*        Compute the current K-th column of F:
+*          1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K).
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL CGEMV( 'Conjugate transpose', M-I+1, N+NRHS-K,
+     $                  TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1,
+     $                  CZERO, F( K+1, K ), 1 )
+         END IF
+*
+*           2) Zero out elements above and on the diagonal of the
+*              column K in matrix F, i.e elements F(1:K,K).
+*
+         DO J = 1, K
+            F( J, K ) = CZERO
+         END DO
+*
+*         3) Incremental updating of the K-th column of F:
+*        F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H
+*                    * A(I:M,K).
+*
+         IF( K.GT.1 ) THEN
+            CALL CGEMV( 'Conjugate Transpose', M-I+1, K-1, -TAU( K ),
+     $                   A( I, 1 ), LDA, A( I, K ), 1, CZERO,
+     $                   AUXV( 1 ), 1 )
+*
+            CALL CGEMV( 'No transpose', N+NRHS, K-1, CONE,
+     $                  F( 1, 1 ), LDF, AUXV( 1 ), 1, CONE,
+     $                  F( 1, K ), 1 )
+         END IF
+*
+*        ===============================================================
+*
+*        Update the current I-th row of A:
+*        A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS)
+*                         - A(I,1:K)*F(K+1:N+NRHS,1:K)**H.
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $            1, N+NRHS-K, K, -CONE, A( I, 1 ), LDA,
+     $            F( K+1, 1 ), LDF, CONE, A( I, K+1 ), LDA )
+         END IF
+*
+         A( I, K ) = AIK
+*
+*        Update the partial column 2-norms for the residual matrix,
+*        only if the residual matrix A(I+1:M,K+1:N) exists, i.e.
+*        when K < MINMNFACT = min( M-IOFFSET, N ).
+*
+         IF( K.LT.MINMNFACT ) THEN
+*
+            DO J = K + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ABS( A( I, J ) ) / VN1( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2.LE.TOL3Z ) THEN
+*
+*                    At J-index, we have a difficult column for the
+*                    update of the 2-norm. Save the index of the previous
+*                    difficult column in IWORK(J-1).
+*                    NOTE: ILSTCC > 1, threfore we can use IWORK only
+*                    with N-1 elements, where the elements are
+*                    shifted by 1 to the left.
+*
+                     IWORK( J-1 ) = LSTICC
+*
+*                    Set the index of the last difficult column LSTICC.
+*
+                     LSTICC = J
+*
+                  ELSE
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*        End of while loop.
+*
+      END DO
+*
+*     Now, afler the loop:
+*        Set KB, the number of factorized columns in the block;
+*        Set IF, the number of processed rows in the block, which
+*                is the same as the number of processed rows in
+*                the original whole matrix A_orig, IF = IOFFSET + KB.
+*
+      KB = K
+      IF = I
+*
+*     Apply the block reflector to the residual of the matrix A
+*     and the residual of the right hand sides B, if the residual
+*     matrix and and/or the residual of the right hand sides
+*     exist,  i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists.
+*     This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*     A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                         A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H.
+*
+      IF( KB.LT.MINMNUPDT ) THEN
+         CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $         M-IF, N+NRHS-KB, KB, -CONE, A( IF+1, 1 ), LDA,
+     $         F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA )
+      END IF
+*
+*     Recompute the 2-norm of the difficult columns.
+*     Loop over the index of the difficult columns from the largest
+*     to the smallest index.
+*
+      DO WHILE( LSTICC.GT.0 )
+*
+*        LSTICC is the index of the last difficult column is greater
+*        than 1.
+*        ITEMP is the index of the previous difficult column.
+*
+         ITEMP = IWORK( LSTICC-1 )
+*
+*        Compute the 2-norm explicilty for the last difficult column and
+*        save it in the partial and exact 2-norm vectors VN1 and VN2.
+*
+*        NOTE: The computation of VN1( LSTICC ) relies on the fact that
+*        SCNRM2 does not fail on vectors with norm below the value of
+*        SQRT(SLAMCH('S'))
+*
+         VN1( LSTICC ) = SCNRM2( M-IF, A( IF+1, LSTICC ), 1 )
+         VN2( LSTICC ) = VN1( LSTICC )
+*
+*        Downdate the index of the last difficult column to
+*        the index of the previous difficult column.
+*
+         LSTICC = ITEMP
+*
+      END DO
+*
+      RETURN
+*
+*     End of CLAQP3RK
+*
+      END

lapack-netlib/SRC/dlaqp2rk.c

@@ -0,0 +1,923 @@
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) {ceil(w)}
+#define myhuge_(w) {HUGE_VAL}
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+	complex pow={1.0,0.0}; unsigned long int u;
+		if(n != 0) {
+		if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+		for(u = n; ; ) {
+			if(u & 01) pow.r *= x.r, pow.i *= x.i;
+			if(u >>= 1) x.r *= x.r, x.i *= x.i;
+			else break;
+		}
+	}
+	_Fcomplex p={pow.r, pow.i};
+	return p;
+}
+#else
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+	_Dcomplex pow={1.0,0.0}; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+		for(u = n; ; ) {
+			if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+			if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+			else break;
+		}
+	}
+	_Dcomplex p = {pow._Val[0], pow._Val[1]};
+	return p;
+}
+#else
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaqp2rk_(integer *m, integer *n, integer *nrhs, integer 
+	*ioffset, integer *kmax, doublereal *abstol, doublereal *reltol, 
+	integer *kp1, doublereal *maxc2nrm, doublereal *a, integer *lda, 
+	integer *k, doublereal *maxc2nrmk, doublereal *relmaxc2nrmk, integer *
+	jpiv, doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *
+	work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1, d__2;
+
+    /* Local variables */
+    doublereal aikk, temp;
+    extern doublereal dnrm2_(integer *, doublereal *, integer *);
+    doublereal temp2;
+    integer i__, j;
+    doublereal tol3z;
+    integer jmaxc2nrm;
+    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *);
+    integer itemp;
+    extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, 
+	    doublereal *, integer *);
+    integer minmnfact;
+    doublereal myhugeval;
+    integer minmnupdt, kk;
+    extern doublereal dlamch_(char *);
+    integer kp;
+    extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+	     integer *, doublereal *);
+    extern integer idamax_(integer *, doublereal *, integer *);
+    extern logical disnan_(doublereal *);
+
+
+/*  -- LAPACK auxiliary routine -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/*  ===================================================================== */
+
+
+/*     Initialize INFO */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpiv;
+    --tau;
+    --vn1;
+    --vn2;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+
+/*     MINMNFACT in the smallest dimension of the submatrix */
+/*     A(IOFFSET+1:M,1:N) to be factorized. */
+
+/*     MINMNUPDT is the smallest dimension */
+/*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which */
+/*     contains the submatrices A(IOFFSET+1:M,1:N) and */
+/*     B(IOFFSET+1:M,1:NRHS) as column blocks. */
+
+/* Computing MIN */
+    i__1 = *m - *ioffset;
+    minmnfact = f2cmin(i__1,*n);
+/* Computing MIN */
+    i__1 = *m - *ioffset, i__2 = *n + *nrhs;
+    minmnupdt = f2cmin(i__1,i__2);
+    *kmax = f2cmin(*kmax,minmnfact);
+    tol3z = sqrt(dlamch_("Epsilon"));
+    myhugeval = dlamch_("Overflow");
+
+/*     Compute the factorization, KK is the lomn loop index. */
+
+    i__1 = *kmax;
+    for (kk = 1; kk <= i__1; ++kk) {
+
+	i__ = *ioffset + kk;
+
+	if (i__ == 1) {
+
+/*           ============================================================ */
+
+/*           We are at the first column of the original whole matrix A, */
+/*           therefore we use the computed KP1 and MAXC2NRM from the */
+/*           main routine. */
+
+	    kp = *kp1;
+
+/*           ============================================================ */
+
+	} else {
+
+/*           ============================================================ */
+
+/*           Determine the pivot column in KK-th step, i.e. the index */
+/*           of the column with the maximum 2-norm in the */
+/*           submatrix A(I:M,K:N). */
+
+	    i__2 = *n - kk + 1;
+	    kp = kk - 1 + idamax_(&i__2, &vn1[kk], &c__1);
+
+/*           Determine the maximum column 2-norm and the relative maximum */
+/*           column 2-norm of the submatrix A(I:M,KK:N) in step KK. */
+/*           RELMAXC2NRMK  will be computed later, after somecondition */
+/*           checks on MAXC2NRMK. */
+
+	    *maxc2nrmk = vn1[kp];
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains NaN, and set */
+/*           INFO parameter to the column number, where the first NaN */
+/*           is found and return from the routine. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (disnan_(maxc2nrmk)) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*info = *k + kp;
+
+/*               Set RELMAXC2NRMK to NaN. */
+
+		*relmaxc2nrmk = *maxc2nrmk;
+
+/*               Array TAU(K+1:MINMNFACT) is not set and contains */
+/*               undefined elements. */
+
+		return 0;
+	    }
+
+/*           ============================================================ */
+
+/*           Quick return, if the submatrix A(I:M,KK:N) is */
+/*           a zero matrix. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*maxc2nrmk == 0.) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*relmaxc2nrmk = 0.;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    tau[j] = 0.;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains Inf, */
+/*           set INFO parameter to the column number, where */
+/*           the first Inf is found plus N, and continue */
+/*           the computation. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*info == 0 && *maxc2nrmk > myhugeval) {
+		*info = *n + kk - 1 + kp;
+	    }
+
+/*           ============================================================ */
+
+/*           Test for the second and third stopping criteria. */
+/*           NOTE: There is no need to test for ABSTOL >= ZERO, since */
+/*           MAXC2NRMK is non-negative. Similarly, there is no need */
+/*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is */
+/*           non-negative. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+
+	    if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) {
+
+/*              Set K, the number of factorized columns. */
+
+		*k = kk - 1;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    tau[j] = 0.;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           End ELSE of IF(I.EQ.1) */
+
+	}
+
+/*        =============================================================== */
+
+/*        If the pivot column is not the first column of the */
+/*        subblock A(1:M,KK:N): */
+/*        1) swap the KK-th column and the KP-th pivot column */
+/*           in A(1:M,1:N); */
+/*        2) copy the KK-th element into the KP-th element of the partial */
+/*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */
+/*           for VN1 and VN2 since we use the element with the index */
+/*           larger than KK in the next loop step.) */
+/*        3) Save the pivot interchange with the indices relative to the */
+/*           the original matrix A, not the block A(1:M,1:N). */
+
+	if (kp != kk) {
+	    dswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1);
+	    vn1[kp] = vn1[kk];
+	    vn2[kp] = vn2[kk];
+	    itemp = jpiv[kp];
+	    jpiv[kp] = jpiv[kk];
+	    jpiv[kk] = itemp;
+	}
+
+/*        Generate elementary reflector H(KK) using the column A(I:M,KK), */
+/*        if the column has more than one element, otherwise */
+/*        the elementary reflector would be an identity matrix, */
+/*        and TAU(KK) = ZERO. */
+
+	if (i__ < *m) {
+	    i__2 = *m - i__ + 1;
+	    dlarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], &
+		    c__1, &tau[kk]);
+	} else {
+	    tau[kk] = 0.;
+	}
+
+/*        Check if TAU(KK) contains NaN, set INFO parameter */
+/*        to the column number where NaN is found and return from */
+/*        the routine. */
+/*        NOTE: There is no need to check TAU(KK) for Inf, */
+/*        since DLARFG cannot produce TAU(KK) or Householder vector */
+/*        below the diagonal containing Inf. Only BETA on the diagonal, */
+/*        returned by DLARFG can contain Inf, which requires */
+/*        TAU(KK) to contain NaN. Therefore, this case of generating Inf */
+/*        by DLARFG is covered by checking TAU(KK) for NaN. */
+
+	if (disnan_(&tau[kk])) {
+	    *k = kk - 1;
+	    *info = kk;
+
+/*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN. */
+
+	    *maxc2nrmk = tau[kk];
+	    *relmaxc2nrmk = tau[kk];
+
+/*           Array TAU(KK:MINMNFACT) is not set and contains */
+/*           undefined elements, except the first element TAU(KK) = NaN. */
+
+	    return 0;
+	}
+
+/*        Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. */
+/*        ( If M >= N, then at KK = N there is no residual matrix, */
+/*         i.e. no columns of A to update, only columns of B. */
+/*         If M < N, then at KK = M-IOFFSET, I = M and we have a */
+/*         one-row residual matrix in A and the elementary */
+/*         reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update */
+/*         is needed for the residual matrix in A and the */
+/*         right-hand-side-matrix in B. */
+/*         Therefore, we update only if */
+/*         KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */
+/*         condition is satisfied, not only KK < N+NRHS ) */
+
+	if (kk < minmnupdt) {
+	    aikk = a[i__ + kk * a_dim1];
+	    a[i__ + kk * a_dim1] = 1.;
+	    i__2 = *m - i__ + 1;
+	    i__3 = *n + *nrhs - kk;
+	    dlarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &tau[
+		    kk], &a[i__ + (kk + 1) * a_dim1], lda, &work[1]);
+	    a[i__ + kk * a_dim1] = aikk;
+	}
+
+	if (kk < minmnfact) {
+
+/*           Update the partial column 2-norms for the residual matrix, */
+/*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */
+/*           when KK < f2cmin(M-IOFFSET, N). */
+
+	    i__2 = *n;
+	    for (j = kk + 1; j <= i__2; ++j) {
+		if (vn1[j] != 0.) {
+
+/*                 NOTE: The following lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+/* Computing 2nd power */
+		    d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / vn1[j];
+		    temp = 1. - d__2 * d__2;
+		    temp = f2cmax(temp,0.);
+/* Computing 2nd power */
+		    d__1 = vn1[j] / vn2[j];
+		    temp2 = temp * (d__1 * d__1);
+		    if (temp2 <= tol3z) {
+
+/*                    Compute the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by explicitly computing it, */
+/*                    and store it in both partial 2-norm vector VN1 */
+/*                    and exact column 2-norm vector VN2. */
+
+			i__3 = *m - i__;
+			vn1[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], &
+				c__1);
+			vn2[j] = vn1[j];
+
+		    } else {
+
+/*                    Update the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by removing one */
+/*                    element A(I,J) and store it in partial */
+/*                    2-norm vector VN1. */
+
+			vn1[j] *= sqrt(temp);
+
+		    }
+		}
+	    }
+
+	}
+
+/*     End factorization loop */
+
+    }
+
+/*     If we reached this point, all colunms have been factorized, */
+/*     i.e. no condition was triggered to exit the routine. */
+/*     Set the number of factorized columns. */
+
+    *k = *kmax;
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */
+/*     we return. */
+
+    if (*k < minmnfact) {
+
+	i__1 = *n - *k;
+	jmaxc2nrm = *k + idamax_(&i__1, &vn1[*k + 1], &c__1);
+	*maxc2nrmk = vn1[jmaxc2nrm];
+
+	if (*k == 0) {
+	    *relmaxc2nrmk = 1.;
+	} else {
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+	}
+
+    } else {
+	*maxc2nrmk = 0.;
+	*relmaxc2nrmk = 0.;
+    }
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, set TAUs corresponding to the columns that were */
+/*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. */
+
+    i__1 = minmnfact;
+    for (j = *k + 1; j <= i__1; ++j) {
+	tau[j] = 0.;
+    }
+
+    return 0;
+
+/*     End of DLAQP2RK */
+
+} /* dlaqp2rk_ */
+

lapack-netlib/SRC/dlaqp2rk.f

@@ -0,0 +1,713 @@
+*> \brief \b DLAQP2RK computes truncated QR factorization with column pivoting of a real matrix block using Level 2 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLAQP2RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqp2rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqp2rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqp2rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+*     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+*     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+*     $                     INFO )
+*      IMPLICIT NONE
+*
+*     .. Scalar Arguments ..
+*      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+*      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            JPIV( * )
+*      DOUBLE PRECISION   A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+*     $                   WORK( * )
+*       ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> DLAQP2RK computes a truncated (rank K) or full rank Householder QR
+*> factorization with column pivoting of a real matrix
+*> block A(IOFFSET+1:M,1:N) as
+*>
+*>   A * P(K) = Q(K) * R(K).
+*>
+*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N)
+*> is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides matrix block B
+*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] KMAX
+*> \verbatim
+*>          KMAX is INTEGER
+*>
+*>          The first factorization stopping criterion. KMAX >= 0.
+*>
+*>          The maximum number of columns of the matrix A to factorize,
+*>          i.e. the maximum factorization rank.
+*>
+*>          a) If KMAX >= min(M-IOFFSET,N), then this stopping
+*>                criterion is not used, factorize columns
+*>                depending on ABSTOL and RELTOL.
+*>
+*>          b) If KMAX = 0, then this stopping criterion is
+*>             satisfied on input and the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The second factorization stopping criterion.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The third factorization stopping criterion.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine DGEQP3RK. 1 <= KP1 <= N_orig_mat.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is DOUBLE PRECISION
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine DGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is DOUBLE PRECISION array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:K) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(K) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:K) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,K+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(K)**T.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] K
+*> \verbatim
+*>          K is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N).
+*>
+*>          K also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is DOUBLE PRECISION
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank K. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is DOUBLE PRECISION
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank K) to the maximum column 2-norm of the
+*>          whole original matrix A. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is DOUBLE PRECISION array, dimension (N-1)
+*>          Used in DLARF subroutine to apply an elementary
+*>          reflector from the left.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step K+1 ( when K columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             K                  is set to the number of
+*>                                   factorized columns without
+*>                                   exception.
+*>             MAXC2NRMK          is set to NaN.
+*>             RELMAXC2NRMK       is set to NaN.
+*>             TAU(K+1:min(M,N))  is not set and contains undefined
+*>                                   elements. If j_1=K+1, TAU(K+1)
+*>                                   may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the factorization
+*>             step K+1 ( when K columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp2rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+     $                     INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+     $                   WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
+     $                   MINMNUPDT
+      DOUBLE PRECISION   AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, DSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            DISNAN
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DNRM2
+      EXTERNAL           DISNAN, DLAMCH, IDAMAX, DNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+*     MINMNUPDT is the smallest dimension
+*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which
+*     contains the submatrices A(IOFFSET+1:M,1:N) and
+*     B(IOFFSET+1:M,1:NRHS) as column blocks.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      KMAX = MIN( KMAX, MINMNFACT )
+      TOL3Z = SQRT( DLAMCH( 'Epsilon' ) )
+      HUGEVAL = DLAMCH( 'Overflow' )
+*
+*     Compute the factorization, KK is the lomn loop index.
+*
+      DO KK = 1, KMAX
+*
+         I = IOFFSET + KK
+*
+         IF( I.EQ.1 ) THEN
+*
+*           ============================================================
+*
+*           We are at the first column of the original whole matrix A,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+
+            KP = KP1
+*
+*           ============================================================
+*
+         ELSE
+*
+*           ============================================================
+*
+*           Determine the pivot column in KK-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,KK:N) in step KK.
+*           RELMAXC2NRMK  will be computed later, after somecondition
+*           checks on MAXC2NRMK.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains NaN, and set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( DISNAN( MAXC2NRMK ) ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+                K = KK - 1
+                INFO = K + KP
+*
+*               Set RELMAXC2NRMK to NaN.
+*
+                RELMAXC2NRMK = MAXC2NRMK
+*
+*               Array TAU(K+1:MINMNFACT) is not set and contains
+*               undefined elements.
+*
+               RETURN
+            END IF
+*
+*           ============================================================
+*
+*           Quick return, if the submatrix A(I:M,KK:N) is
+*           a zero matrix.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+               K = KK - 1
+               RELMAXC2NRMK = ZERO
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + KK - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third stopping criteria.
+*           NOTE: There is no need to test for ABSTOL >= ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+*              Set K, the number of factorized columns.
+*
+               K = KK - 1
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,KK:N):
+*        1) swap the KK-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) copy the KK-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than KK in the next loop step.)
+*        3) Save the pivot interchange with the indices relative to the
+*           the original matrix A, not the block A(1:M,1:N).
+*
+         IF( KP.NE.KK ) THEN
+            CALL DSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 )
+            VN1( KP ) = VN1( KK )
+            VN2( KP ) = VN2( KK )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( KK )
+            JPIV( KK ) = ITEMP
+         END IF
+*
+*        Generate elementary reflector H(KK) using the column A(I:M,KK),
+*        if the column has more than one element, otherwise
+*        the elementary reflector would be an identity matrix,
+*        and TAU(KK) = ZERO.
+*
+         IF( I.LT.M ) THEN
+            CALL DLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1,
+     $                   TAU( KK ) )
+         ELSE
+            TAU( KK ) = ZERO
+         END IF
+*
+*        Check if TAU(KK) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(KK) for Inf,
+*        since DLARFG cannot produce TAU(KK) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by DLARFG can contain Inf, which requires
+*        TAU(KK) to contain NaN. Therefore, this case of generating Inf
+*        by DLARFG is covered by checking TAU(KK) for NaN.
+*
+         IF( DISNAN( TAU(KK) ) ) THEN
+            K = KK - 1
+            INFO = KK
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAU( KK )
+            RELMAXC2NRMK = TAU( KK )
+*
+*           Array TAU(KK:MINMNFACT) is not set and contains
+*           undefined elements, except the first element TAU(KK) = NaN.
+*
+            RETURN
+         END IF
+*
+*        Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left.
+*        ( If M >= N, then at KK = N there is no residual matrix,
+*         i.e. no columns of A to update, only columns of B.
+*         If M < N, then at KK = M-IOFFSET, I = M and we have a
+*         one-row residual matrix in A and the elementary
+*         reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update
+*         is needed for the residual matrix in A and the
+*         right-hand-side-matrix in B.
+*         Therefore, we update only if
+*         KK < MINMNUPDT = min(M-IOFFSET, N+NRHS)
+*         condition is satisfied, not only KK < N+NRHS )
+*
+         IF( KK.LT.MINMNUPDT ) THEN
+            AIKK = A( I, KK )
+            A( I, KK ) = ONE
+            CALL DLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+     $                  TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) )
+            A( I, KK ) = AIKK
+         END IF
+*
+         IF( KK.LT.MINMNFACT ) THEN
+*
+*           Update the partial column 2-norms for the residual matrix,
+*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e.
+*           when KK < min(M-IOFFSET, N).
+*
+            DO J = KK + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2
+                  TEMP = MAX( TEMP, ZERO )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN
+*
+*                    Compute the column 2-norm for the partial
+*                    column A(I+1:M,J) by explicitly computing it,
+*                    and store it in both partial 2-norm vector VN1
+*                    and exact column 2-norm vector VN2.
+*
+                     VN1( J ) = DNRM2( M-I, A( I+1, J ), 1 )
+                     VN2( J ) = VN1( J )
+*
+                  ELSE
+*
+*                    Update the column 2-norm for the partial
+*                    column A(I+1:M,J) by removing one
+*                    element A(I,J) and store it in partial
+*                    2-norm vector VN1.
+*
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+*
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*     End factorization loop
+*
+      END DO
+*
+*     If we reached this point, all colunms have been factorized,
+*     i.e. no condition was triggered to exit the routine.
+*     Set the number of factorized columns.
+*
+      K = KMAX
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
+*     we return.
+*
+      IF( K.LT.MINMNFACT ) THEN
+*
+         JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 )
+         MAXC2NRMK = VN1( JMAXC2NRM )
+*
+         IF( K.EQ.0 ) THEN
+            RELMAXC2NRMK = ONE
+         ELSE
+            RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM
+         END IF
+*
+      ELSE
+         MAXC2NRMK = ZERO
+         RELMAXC2NRMK = ZERO
+      END IF
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, set TAUs corresponding to the columns that were
+*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO.
+*
+      DO J = K + 1, MINMNFACT
+         TAU( J ) = ZERO
+      END DO
+*
+      RETURN
+*
+*     End of DLAQP2RK
+*
+      END

lapack-netlib/SRC/dlaqp3rk.f

@@ -0,0 +1,935 @@
+*> \brief \b DLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLAQP3RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqp3rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqp3rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqp3rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+*     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+*     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+*     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+*      IMPLICIT NONE
+*      LOGICAL            DONE
+*      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+*     $                   NB, NRHS
+*      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*
+*     .. Scalar Arguments ..
+*      LOGICAL            DONE
+*      INTEGER            KB, LDA, LDF, M, N, NB, NRHS, IOFFSET
+*      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            IWORK( * ), JPIV( * )
+*      DOUBLE PRECISION   A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+*     $                   VN1( * ), VN2( * )
+*     ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> DLAQP3RK computes a step of truncated QR factorization with column
+*> pivoting of a real M-by-N matrix A block A(IOFFSET+1:M,1:N)
+*> by using Level 3 BLAS as
+*>
+*>   A * P(KB) = Q(KB) * R(KB).
+*>
+*> The routine tries to factorize NB columns from A starting from
+*> the row IOFFSET+1 and updates the residual matrix with BLAS 3
+*> xGEMM. The number of actually factorized columns is returned
+*> is smaller than NB.
+*>
+*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides B matrix stored
+*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**T * B.
+*>
+*> Cases when the number of factorized columns KB < NB:
+*>
+*> (1) In some cases, due to catastrophic cancellations, it cannot
+*> factorize all NB columns and need to update the residual matrix.
+*> Hence, the actual number of factorized columns in the block returned
+*> in KB is smaller than NB. The logical DONE is returned as FALSE.
+*> The factorization of the whole original matrix A_orig must proceed
+*> with the next block.
+*>
+*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB.
+*>
+*> (3) In case both stopping criteria ABSTOL or RELTOL are not used,
+*> and when the residual matrix is a zero matrix in some factorization
+*> step KB, the factorization of the whole original matrix A_orig is
+*> stopped, the logical DONE is returned as TRUE. The number of
+*> factorized columns which is smaller than NB is returned in KB.
+*>
+*> (4) Whenever NaN is detected in the matrix A or in the array TAU,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB. The INFO
+*> parameter is set to the column index of the first NaN occurrence.
+*>
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*>          NB is INTEGER
+*>          Factorization block size, i.e the number of columns
+*>          to factorize in the matrix A. 0 <= NB
+*>
+*>          If NB = 0, then the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine DGEQP3RK. 1 <= KP1 <= N_orig.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is DOUBLE PRECISION
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine DGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is DOUBLE PRECISION array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:KB) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(KB) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:KB) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,KB+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(KB)**T.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out]
+*> \verbatim
+*>          DONE is LOGICAL
+*>          TRUE: a) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to ABSTOL
+*>                   or RELTOL criterion,
+*>                b) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to the
+*>                   residual matrix being a ZERO matrix.
+*>                c) when NaN was detected in the matrix A
+*>                   or in the array TAU.
+*>          FALSE: otherwise.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*>          KB is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R.  0 <= KB <= min(M-IOFFSET,NB,N).
+*>
+*>          KB also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is DOUBLE PRECISION
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank KB. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is DOUBLE PRECISION
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank KB) to the maximum column 2-norm of the
+*>          original matrix A_orig. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] AUXV
+*> \verbatim
+*>          AUXV is DOUBLE PRECISION array, dimension (NB)
+*>          Auxiliary vector.
+*> \endverbatim
+*>
+*> \param[out] F
+*> \verbatim
+*>          F is DOUBLE PRECISION array, dimension (LDF,NB)
+*>          Matrix F**T = L*(Y**T)*A.
+*> \endverbatim
+*>
+*> \param[in] LDF
+*> \verbatim
+*>          LDF is INTEGER
+*>          The leading dimension of the array F. LDF >= max(1,N+NRHS).
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*>          IWORK is INTEGER array, dimension (N-1).
+*>          Is a work array. ( IWORK is used to store indices
+*>          of "bad" columns for norm downdating in the residual
+*>          matrix ).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step KB+1 ( when KB columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             KB                  is set to the number of
+*>                                    factorized columns without
+*>                                    exception.
+*>             MAXC2NRMK           is set to NaN.
+*>             RELMAXC2NRMK        is set to NaN.
+*>             TAU(KB+1:min(M,N))     is not set and contains undefined
+*>                                    elements. If j_1=KB+1, TAU(KB+1)
+*>                                    may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the actorization
+*>             step KB+1 ( when KB columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp3rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      LOGICAL            DONE
+      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+     $                   NB, NRHS
+      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * ), JPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+     $                   VN1( * ), VN2( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITEMP, J, K, MINMNFACT, MINMNUPDT,
+     $                   LSTICC, KP, I, IF
+      DOUBLE PRECISION   AIK, HUGEVAL, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DGEMV, DLARFG, DSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            DISNAN
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DNRM2
+      EXTERNAL           DISNAN, DLAMCH, IDAMAX, DNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      NB = MIN( NB, MINMNFACT )
+      TOL3Z = SQRT( DLAMCH( 'Epsilon' ) )
+      HUGEVAL = DLAMCH( 'Overflow' )
+*
+*     Compute factorization in a while loop over NB columns,
+*     K is the column index in the block A(1:M,1:N).
+*
+      K = 0
+      LSTICC = 0
+      DONE = .FALSE.
+*
+      DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 )
+         K = K + 1
+         I = IOFFSET + K
+*
+         IF( I.EQ.1 ) THEN
+*
+*           We are at the first column of the original whole matrix A_orig,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+            KP = KP1
+*
+         ELSE
+*
+*           Determine the pivot column in K-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,K:N) in step K.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains NaN, set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( DISNAN( MAXC2NRMK ) ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               INFO = KB + KP
+*
+*              Set RELMAXC2NRMK to NaN.
+*
+               RELMAXC2NRMK = MAXC2NRMK
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix contains NaN and we stop
+*              the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T.
+
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                  M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Array TAU(KF+1:MINMNFACT) is not set and contains
+*              undefined elements.
+*
+*              Return from the routine.
+*
+               RETURN
+            END IF
+*
+*           Quick return, if the submatrix A(I:M,K:N) is
+*           a zero matrix. We need to check it only if the column index
+*           (same as row index) is larger than 1, since the condition
+*           for the whole original matrix A_orig is checked in the main
+*           routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               RELMAXC2NRMK = ZERO
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix is zero and we stop the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T.
+*
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                  M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = ZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + K - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third tolerance stopping criteria.
+*           NOTE: There is no need to test for ABSTOL.GE.ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig;
+*
+                  KB = K - 1
+                  IF = I - 1
+*
+*              Apply the block reflector to the residual of the
+*              matrix A and the residual of the right hand sides B, if
+*              the residual matrix and and/or the residual of the right
+*              hand sides exist,  i.e. if the submatrix
+*              A(I+1:M,KB+1:N+NRHS) exists.  This occurs when
+*                 KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*              A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                             A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T.
+*
+               IF( KB.LT.MINMNUPDT ) THEN
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                  M-IF, N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA,
+     $                  F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = ZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,K:N):
+*        1) swap the K-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) swap the K-th row and the KP-th row in F(1:N,1:K-1)
+*        3) copy the K-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. (Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than K in the next loop step.)
+*        4) Save the pivot interchange with the indices relative to the
+*           the original matrix A_orig, not the block A(1:M,1:N).
+*
+         IF( KP.NE.K ) THEN
+            CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 )
+            CALL DSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF )
+            VN1( KP ) = VN1( K )
+            VN2( KP ) = VN2( K )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( K )
+            JPIV( K ) = ITEMP
+         END IF
+*
+*        Apply previous Householder reflectors to column K:
+*        A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T.
+*
+         IF( K.GT.1 ) THEN
+            CALL DGEMV( 'No transpose', M-I+1, K-1, -ONE, A( I, 1 ),
+     $                  LDA, F( K, 1 ), LDF, ONE, A( I, K ), 1 )
+         END IF
+*
+*        Generate elementary reflector H(k) using the column A(I:M,K).
+*
+         IF( I.LT.M ) THEN
+            CALL DLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) )
+         ELSE
+            TAU( K ) = ZERO
+         END IF
+*
+*        Check if TAU(K) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(K) for Inf,
+*        since DLARFG cannot produce TAU(K) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by DLARFG can contain Inf, which requires
+*        TAU(K) to contain NaN. Therefore, this case of generating Inf
+*        by DLARFG is covered by checking TAU(K) for NaN.
+*
+         IF( DISNAN( TAU(K) ) ) THEN
+*
+            DONE = .TRUE.
+*
+*           Set KB, the number of factorized partial columns
+*                   that are non-zero in each step in the block,
+*                   i.e. the rank of the factor R.
+*           Set IF, the number of processed rows in the block, which
+*                   is the same as the number of processed rows in
+*                   the original whole matrix A_orig.
+*
+            KB = K - 1
+            IF = I - 1
+            INFO = K
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAU( K )
+            RELMAXC2NRMK = TAU( K )
+*
+*           There is no need to apply the block reflector to the
+*           residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*           since the submatrix contains NaN and we stop
+*           the computation.
+*           But, we need to apply the block reflector to the residual
+*           right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*           residual right hand sides exist.  This occurs
+*           when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*           A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                            A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T.
+*
+            IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+               CALL DGEMM( 'No transpose', 'Transpose',
+     $               M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA,
+     $               F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA )
+            END IF
+*
+*           There is no need to recompute the 2-norm of the
+*           difficult columns, since we stop the factorization.
+*
+*           Array TAU(KF+1:MINMNFACT) is not set and contains
+*           undefined elements.
+*
+*           Return from the routine.
+*
+            RETURN
+         END IF
+*
+*        ===============================================================
+*
+         AIK = A( I, K )
+         A( I, K ) = ONE
+*
+*        ===============================================================
+*
+*        Compute the current K-th column of F:
+*          1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K).
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL DGEMV( 'Transpose', M-I+1, N+NRHS-K,
+     $                  TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1,
+     $                  ZERO, F( K+1, K ), 1 )
+         END IF
+*
+*           2) Zero out elements above and on the diagonal of the
+*              column K in matrix F, i.e elements F(1:K,K).
+*
+         DO J = 1, K
+            F( J, K ) = ZERO
+         END DO
+*
+*         3) Incremental updating of the K-th column of F:
+*        F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T
+*                    * A(I:M,K).
+*
+         IF( K.GT.1 ) THEN
+            CALL DGEMV( 'Transpose', M-I+1, K-1, -TAU( K ),
+     $                  A( I, 1 ), LDA, A( I, K ), 1, ZERO,
+     $                  AUXV( 1 ), 1 )
+*
+            CALL DGEMV( 'No transpose', N+NRHS, K-1, ONE,
+     $                  F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE,
+     $                  F( 1, K ), 1 )
+         END IF
+*
+*        ===============================================================
+*
+*        Update the current I-th row of A:
+*        A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS)
+*                         - A(I,1:K)*F(K+1:N+NRHS,1:K)**T.
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL DGEMV( 'No transpose', N+NRHS-K, K, -ONE,
+     $                  F( K+1, 1 ), LDF, A( I, 1 ), LDA, ONE,
+     $                  A( I, K+1 ), LDA )
+         END IF
+*
+         A( I, K ) = AIK
+*
+*        Update the partial column 2-norms for the residual matrix,
+*        only if the residual matrix A(I+1:M,K+1:N) exists, i.e.
+*        when K < MINMNFACT = min( M-IOFFSET, N ).
+*
+         IF( K.LT.MINMNFACT ) THEN
+*
+            DO J = K + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ABS( A( I, J ) ) / VN1( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2.LE.TOL3Z ) THEN
+*
+*                    At J-index, we have a difficult column for the
+*                    update of the 2-norm. Save the index of the previous
+*                    difficult column in IWORK(J-1).
+*                    NOTE: ILSTCC > 1, threfore we can use IWORK only
+*                    with N-1 elements, where the elements are
+*                    shifted by 1 to the left.
+*
+                     IWORK( J-1 ) = LSTICC
+*
+*                    Set the index of the last difficult column LSTICC.
+*
+                     LSTICC = J
+*
+                  ELSE
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*        End of while loop.
+*
+      END DO
+*
+*     Now, afler the loop:
+*        Set KB, the number of factorized columns in the block;
+*        Set IF, the number of processed rows in the block, which
+*                is the same as the number of processed rows in
+*                the original whole matrix A_orig, IF = IOFFSET + KB.
+*
+      KB = K
+      IF = I
+*
+*     Apply the block reflector to the residual of the matrix A
+*     and the residual of the right hand sides B, if the residual
+*     matrix and and/or the residual of the right hand sides
+*     exist,  i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists.
+*     This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*     A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                         A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T.
+*
+      IF( KB.LT.MINMNUPDT ) THEN
+         CALL DGEMM( 'No transpose', 'Transpose',
+     $         M-IF, N+NRHS-KB, KB, -ONE, A( IF+1, 1 ), LDA,
+     $         F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA )
+      END IF
+*
+*     Recompute the 2-norm of the difficult columns.
+*     Loop over the index of the difficult columns from the largest
+*     to the smallest index.
+*
+      DO WHILE( LSTICC.GT.0 )
+*
+*        LSTICC is the index of the last difficult column is greater
+*        than 1.
+*        ITEMP is the index of the previous difficult column.
+*
+         ITEMP = IWORK( LSTICC-1 )
+*
+*        Compute the 2-norm explicilty for the last difficult column and
+*        save it in the partial and exact 2-norm vectors VN1 and VN2.
+*
+*        NOTE: The computation of VN1( LSTICC ) relies on the fact that
+*        DNRM2 does not fail on vectors with norm below the value of
+*        SQRT(DLAMCH('S'))
+*
+         VN1( LSTICC ) = DNRM2( M-IF, A( IF+1, LSTICC ), 1 )
+         VN2( LSTICC ) = VN1( LSTICC )
+*
+*        Downdate the index of the last difficult column to
+*        the index of the previous difficult column.
+*
+         LSTICC = ITEMP
+*
+      END DO
+*
+      RETURN
+*
+*     End of DLAQP3RK
+*
+      END

lapack-netlib/SRC/ilaenv.c

@@ -191,7 +191,7 @@ typedef struct Namelist Namelist;
 #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
 #ifdef _MSC_VER
 #define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
-#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/df(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
 #else
 #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
 #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
@@ -252,11 +252,11 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
 #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
 #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
 #define myexit_() break;
-#define mycycle() continue;
-#define myceiling(w) {ceil(w)}
-#define myhuge(w) {HUGE_VAL}
+#define mycycle_() continue;
+#define myceiling_(w) {ceil(w)}
+#define myhuge_(w) {HUGE_VAL}
 //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
-#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
 
 /* procedure parameter types for -A and -C++ */
 
@@ -509,12 +509,18 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ
 
 
 
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
 
 /* Table of constant values */
 
 static integer c__1 = 1;
-static real c_b174 = 0.f;
-static real c_b175 = 1.f;
+static real c_b179 = 0.f;
+static real c_b180 = 1.f;
 static integer c__0 = 0;
 
 /* > \brief \b ILAENV */
@@ -599,9 +605,9 @@ f"> */
 /* >          = 9: maximum size of the subproblems at the bottom of the */
 /* >               computation tree in the divide-and-conquer algorithm */
 /* >               (used by xGELSD and xGESDD) */
-/* >          =10: ieee NaN arithmetic can be trusted not to trap */
+/* >          =10: ieee infinity and NaN arithmetic can be trusted not to trap */
 /* >          =11: infinity arithmetic can be trusted not to trap */
-/* >          12 <= ISPEC <= 16: */
+/* >          12 <= ISPEC <= 17: */
 /* >               xHSEQR or related subroutines, */
 /* >               see IPARMQ for detailed explanation */
 /* > \endverbatim */
@@ -652,9 +658,7 @@ f"> */
 /* > \author Univ. of Colorado Denver */
 /* > \author NAG Ltd. */
 
-/* > \date November 2019 */
-
-/* > \ingroup OTHERauxiliary */
+/* > \ingroup ilaenv */
 
 /* > \par Further Details: */
 /*  ===================== */
@@ -685,7 +689,7 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
 	opts_len)
 {
     /* System generated locals */
-    integer ret_val;
+    integer ret_val, i__1, i__2, i__3;
 
     /* Local variables */
     logical twostage;
@@ -702,10 +706,9 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
 	    integer *, integer *);
 
 
-/*  -- LAPACK auxiliary routine (version 3.9.0) -- */
+/*  -- LAPACK auxiliary routine -- */
 /*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
 /*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
-/*     November 2019 */
 
 
 /*  ===================================================================== */
@@ -728,6 +731,7 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
 	case 14:  goto L160;
 	case 15:  goto L160;
 	case 16:  goto L160;
+	case 17:  goto L160;
     }
 
 /*     Invalid value for ISPEC */
@@ -908,6 +912,12 @@ L50:
 	    } else {
 		nb = 64;
 	    }
+	} else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) {
+	    if (sname) {
+		nb = 32;
+	    } else {
+		nb = 32;
+	    }
 	}
     } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
 	if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
@@ -1034,6 +1044,21 @@ L50:
 	    } else {
 		nb = 64;
 	    }
+	} else if (s_cmp(c3, "SYL", (ftnlen)3, (ftnlen)3) == 0) {
+/*           The upper bound is to prevent overly aggressive scaling. */
+	    if (sname) {
+/* Computing MIN */
+/* Computing MAX */
+		i__2 = 48, i__3 = (f2cmin(*n1,*n2) << 4) / 100;
+		i__1 = f2cmax(i__2,i__3);
+		nb = f2cmin(i__1,240);
+	    } else {
+/* Computing MIN */
+/* Computing MAX */
+		i__2 = 24, i__3 = (f2cmin(*n1,*n2) << 3) / 100;
+		i__1 = f2cmax(i__2,i__3);
+		nb = f2cmin(i__1,80);
+	    }
 	}
     } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
 	if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
@@ -1042,6 +1067,12 @@ L50:
 	    } else {
 		nb = 64;
 	    }
+	} else if (s_cmp(c3, "TRS", (ftnlen)3, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 32;
+	    } else {
+		nb = 32;
+	    }
 	}
     } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
 	if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
@@ -1093,6 +1124,12 @@ L60:
 	    } else {
 		nbmin = 2;
 	    }
+	} else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) {
+	    if (sname) {
+		nbmin = 2;
+	    } else {
+		nbmin = 2;
+	    }
 	}
     } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
 	if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
@@ -1184,6 +1221,12 @@ L70:
 	    } else {
 		nx = 128;
 	    }
+	} else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) {
+	    if (sname) {
+		nx = 128;
+	    } else {
+		nx = 128;
+	    }
 	}
     } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
 	if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
@@ -1270,29 +1313,29 @@ L130:
 
 L140:
 
-/*     ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */
+/*     ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap */
 
 /*     ILAENV = 0 */
     ret_val = 1;
     if (ret_val == 1) {
-	ret_val = ieeeck_(&c__1, &c_b174, &c_b175);
+	ret_val = ieeeck_(&c__1, &c_b179, &c_b180);
     }
     return ret_val;
 
 L150:
 
-/*     ISPEC = 11: infinity arithmetic can be trusted not to trap */
+/*     ISPEC = 11: ieee infinity arithmetic can be trusted not to trap */
 
 /*     ILAENV = 0 */
     ret_val = 1;
     if (ret_val == 1) {
-	ret_val = ieeeck_(&c__0, &c_b174, &c_b175);
+	ret_val = ieeeck_(&c__0, &c_b179, &c_b180);
     }
     return ret_val;
 
 L160:
 
-/*     12 <= ISPEC <= 16: xHSEQR or related subroutines. */
+/*     12 <= ISPEC <= 17: xHSEQR or related subroutines. */
 
     ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4)
 	    ;

lapack-netlib/SRC/ilaenv.f

@@ -132,7 +132,7 @@
 *> \author Univ. of Colorado Denver
 *> \author NAG Ltd.
 *
-*> \ingroup OTHERauxiliary
+*> \ingroup ilaenv
 *
 *> \par Further Details:
 *  =====================
@@ -355,6 +355,12 @@
             ELSE
                NB = 64
             END IF
+         ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN
+            IF( SNAME ) THEN
+               NB = 32
+            ELSE
+               NB = 32
+            END IF
          END IF
       ELSE IF( C2.EQ.'PO' ) THEN
          IF( C3.EQ.'TRF' ) THEN
@@ -541,7 +547,14 @@
             ELSE
                NBMIN = 2
             END IF
+         ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN
+            IF( SNAME ) THEN
+               NBMIN = 2
+            ELSE
+               NBMIN = 2
+            END IF
          END IF
+
       ELSE IF( C2.EQ.'SY' ) THEN
          IF( C3.EQ.'TRF' ) THEN
             IF( SNAME ) THEN
@@ -618,6 +631,12 @@
             ELSE
                NX = 128
             END IF
+         ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN
+            IF( SNAME ) THEN
+               NX = 128
+            ELSE
+               NX = 128
+            END IF
          END IF
       ELSE IF( C2.EQ.'SY' ) THEN
          IF( SNAME .AND. C3.EQ.'TRD' ) THEN

lapack-netlib/SRC/slaqp2rk.c

@@ -0,0 +1,918 @@
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) {ceil(w)}
+#define myhuge_(w) {HUGE_VAL}
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+	complex pow={1.0,0.0}; unsigned long int u;
+		if(n != 0) {
+		if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+		for(u = n; ; ) {
+			if(u & 01) pow.r *= x.r, pow.i *= x.i;
+			if(u >>= 1) x.r *= x.r, x.i *= x.i;
+			else break;
+		}
+	}
+	_Fcomplex p={pow.r, pow.i};
+	return p;
+}
+#else
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+	_Dcomplex pow={1.0,0.0}; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+		for(u = n; ; ) {
+			if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+			if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+			else break;
+		}
+	}
+	_Dcomplex p = {pow._Val[0], pow._Val[1]};
+	return p;
+}
+#else
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slaqp2rk_(integer *m, integer *n, integer *nrhs, integer 
+	*ioffset, integer *kmax, real *abstol, real *reltol, integer *kp1, 
+	real *maxc2nrm, real *a, integer *lda, integer *k, real *maxc2nrmk, 
+	real *relmaxc2nrmk, integer *jpiv, real *tau, real *vn1, real *vn2, 
+	real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1, r__2;
+
+    /* Local variables */
+    real aikk, temp, temp2;
+    extern real snrm2_(integer *, real *, integer *);
+    integer i__, j;
+    real tol3z;
+    integer jmaxc2nrm;
+    extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, 
+	    integer *, real *, real *, integer *, real *);
+    integer itemp, minmnfact;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *);
+    real myhugeval;
+    integer minmnupdt, kk, kp;
+    extern real slamch_(char *);
+    extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, 
+	    real *);
+    extern integer isamax_(integer *, real *, integer *);
+    extern logical sisnan_(real *);
+
+
+/*  -- LAPACK auxiliary routine -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/*  ===================================================================== */
+
+
+/*     Initialize INFO */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpiv;
+    --tau;
+    --vn1;
+    --vn2;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+
+/*     MINMNFACT in the smallest dimension of the submatrix */
+/*     A(IOFFSET+1:M,1:N) to be factorized. */
+
+/*     MINMNUPDT is the smallest dimension */
+/*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which */
+/*     contains the submatrices A(IOFFSET+1:M,1:N) and */
+/*     B(IOFFSET+1:M,1:NRHS) as column blocks. */
+
+/* Computing MIN */
+    i__1 = *m - *ioffset;
+    minmnfact = f2cmin(i__1,*n);
+/* Computing MIN */
+    i__1 = *m - *ioffset, i__2 = *n + *nrhs;
+    minmnupdt = f2cmin(i__1,i__2);
+    *kmax = f2cmin(*kmax,minmnfact);
+    tol3z = sqrt(slamch_("Epsilon"));
+    myhugeval = slamch_("Overflow");
+
+/*     Compute the factorization, KK is the lomn loop index. */
+
+    i__1 = *kmax;
+    for (kk = 1; kk <= i__1; ++kk) {
+
+	i__ = *ioffset + kk;
+
+	if (i__ == 1) {
+
+/*           ============================================================ */
+
+/*           We are at the first column of the original whole matrix A, */
+/*           therefore we use the computed KP1 and MAXC2NRM from the */
+/*           main routine. */
+
+	    kp = *kp1;
+
+/*           ============================================================ */
+
+	} else {
+
+/*           ============================================================ */
+
+/*           Determine the pivot column in KK-th step, i.e. the index */
+/*           of the column with the maximum 2-norm in the */
+/*           submatrix A(I:M,K:N). */
+
+	    i__2 = *n - kk + 1;
+	    kp = kk - 1 + isamax_(&i__2, &vn1[kk], &c__1);
+
+/*           Determine the maximum column 2-norm and the relative maximum */
+/*           column 2-norm of the submatrix A(I:M,KK:N) in step KK. */
+/*           RELMAXC2NRMK  will be computed later, after somecondition */
+/*           checks on MAXC2NRMK. */
+
+	    *maxc2nrmk = vn1[kp];
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains NaN, and set */
+/*           INFO parameter to the column number, where the first NaN */
+/*           is found and return from the routine. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (sisnan_(maxc2nrmk)) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*info = *k + kp;
+
+/*               Set RELMAXC2NRMK to NaN. */
+
+		*relmaxc2nrmk = *maxc2nrmk;
+
+/*               Array TAU(K+1:MINMNFACT) is not set and contains */
+/*               undefined elements. */
+
+		return 0;
+	    }
+
+/*           ============================================================ */
+
+/*           Quick return, if the submatrix A(I:M,KK:N) is */
+/*           a zero matrix. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*maxc2nrmk == 0.f) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*relmaxc2nrmk = 0.f;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    tau[j] = 0.f;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains Inf, */
+/*           set INFO parameter to the column number, where */
+/*           the first Inf is found plus N, and continue */
+/*           the computation. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*info == 0 && *maxc2nrmk > myhugeval) {
+		*info = *n + kk - 1 + kp;
+	    }
+
+/*           ============================================================ */
+
+/*           Test for the second and third stopping criteria. */
+/*           NOTE: There is no need to test for ABSTOL >= ZERO, since */
+/*           MAXC2NRMK is non-negative. Similarly, there is no need */
+/*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is */
+/*           non-negative. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+
+	    if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) {
+
+/*              Set K, the number of factorized columns. */
+
+		*k = kk - 1;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    tau[j] = 0.f;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           End ELSE of IF(I.EQ.1) */
+
+	}
+
+/*        =============================================================== */
+
+/*        If the pivot column is not the first column of the */
+/*        subblock A(1:M,KK:N): */
+/*        1) swap the KK-th column and the KP-th pivot column */
+/*           in A(1:M,1:N); */
+/*        2) copy the KK-th element into the KP-th element of the partial */
+/*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */
+/*           for VN1 and VN2 since we use the element with the index */
+/*           larger than KK in the next loop step.) */
+/*        3) Save the pivot interchange with the indices relative to the */
+/*           the original matrix A, not the block A(1:M,1:N). */
+
+	if (kp != kk) {
+	    sswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1);
+	    vn1[kp] = vn1[kk];
+	    vn2[kp] = vn2[kk];
+	    itemp = jpiv[kp];
+	    jpiv[kp] = jpiv[kk];
+	    jpiv[kk] = itemp;
+	}
+
+/*        Generate elementary reflector H(KK) using the column A(I:M,KK), */
+/*        if the column has more than one element, otherwise */
+/*        the elementary reflector would be an identity matrix, */
+/*        and TAU(KK) = ZERO. */
+
+	if (i__ < *m) {
+	    i__2 = *m - i__ + 1;
+	    slarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], &
+		    c__1, &tau[kk]);
+	} else {
+	    tau[kk] = 0.f;
+	}
+
+/*        Check if TAU(KK) contains NaN, set INFO parameter */
+/*        to the column number where NaN is found and return from */
+/*        the routine. */
+/*        NOTE: There is no need to check TAU(KK) for Inf, */
+/*        since SLARFG cannot produce TAU(KK) or Householder vector */
+/*        below the diagonal containing Inf. Only BETA on the diagonal, */
+/*        returned by SLARFG can contain Inf, which requires */
+/*        TAU(KK) to contain NaN. Therefore, this case of generating Inf */
+/*        by SLARFG is covered by checking TAU(KK) for NaN. */
+
+	if (sisnan_(&tau[kk])) {
+	    *k = kk - 1;
+	    *info = kk;
+
+/*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN. */
+
+	    *maxc2nrmk = tau[kk];
+	    *relmaxc2nrmk = tau[kk];
+
+/*           Array TAU(KK:MINMNFACT) is not set and contains */
+/*           undefined elements, except the first element TAU(KK) = NaN. */
+
+	    return 0;
+	}
+
+/*        Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. */
+/*        ( If M >= N, then at KK = N there is no residual matrix, */
+/*         i.e. no columns of A to update, only columns of B. */
+/*         If M < N, then at KK = M-IOFFSET, I = M and we have a */
+/*         one-row residual matrix in A and the elementary */
+/*         reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update */
+/*         is needed for the residual matrix in A and the */
+/*         right-hand-side-matrix in B. */
+/*         Therefore, we update only if */
+/*         KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */
+/*         condition is satisfied, not only KK < N+NRHS ) */
+
+	if (kk < minmnupdt) {
+	    aikk = a[i__ + kk * a_dim1];
+	    a[i__ + kk * a_dim1] = 1.f;
+	    i__2 = *m - i__ + 1;
+	    i__3 = *n + *nrhs - kk;
+	    slarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &tau[
+		    kk], &a[i__ + (kk + 1) * a_dim1], lda, &work[1]);
+	    a[i__ + kk * a_dim1] = aikk;
+	}
+
+	if (kk < minmnfact) {
+
+/*           Update the partial column 2-norms for the residual matrix, */
+/*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */
+/*           when KK < f2cmin(M-IOFFSET, N). */
+
+	    i__2 = *n;
+	    for (j = kk + 1; j <= i__2; ++j) {
+		if (vn1[j] != 0.f) {
+
+/*                 NOTE: The following lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+/* Computing 2nd power */
+		    r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)) / vn1[j];
+		    temp = 1.f - r__2 * r__2;
+		    temp = f2cmax(temp,0.f);
+/* Computing 2nd power */
+		    r__1 = vn1[j] / vn2[j];
+		    temp2 = temp * (r__1 * r__1);
+		    if (temp2 <= tol3z) {
+
+/*                    Compute the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by explicitly computing it, */
+/*                    and store it in both partial 2-norm vector VN1 */
+/*                    and exact column 2-norm vector VN2. */
+
+			i__3 = *m - i__;
+			vn1[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1], &
+				c__1);
+			vn2[j] = vn1[j];
+
+		    } else {
+
+/*                    Update the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by removing one */
+/*                    element A(I,J) and store it in partial */
+/*                    2-norm vector VN1. */
+
+			vn1[j] *= sqrt(temp);
+
+		    }
+		}
+	    }
+
+	}
+
+/*     End factorization loop */
+
+    }
+
+/*     If we reached this point, all colunms have been factorized, */
+/*     i.e. no condition was triggered to exit the routine. */
+/*     Set the number of factorized columns. */
+
+    *k = *kmax;
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */
+/*     we return. */
+
+    if (*k < minmnfact) {
+
+	i__1 = *n - *k;
+	jmaxc2nrm = *k + isamax_(&i__1, &vn1[*k + 1], &c__1);
+	*maxc2nrmk = vn1[jmaxc2nrm];
+
+	if (*k == 0) {
+	    *relmaxc2nrmk = 1.f;
+	} else {
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+	}
+
+    } else {
+	*maxc2nrmk = 0.f;
+	*relmaxc2nrmk = 0.f;
+    }
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, set TAUs corresponding to the columns that were */
+/*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. */
+
+    i__1 = minmnfact;
+    for (j = *k + 1; j <= i__1; ++j) {
+	tau[j] = 0.f;
+    }
+
+    return 0;
+
+/*     End of SLAQP2RK */
+
+} /* slaqp2rk_ */
+

lapack-netlib/SRC/slaqp2rk.f

@@ -0,0 +1,713 @@
+*> \brief \b SLAQP2RK computes truncated QR factorization with column pivoting of a real matrix block using Level 2 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SLAQP2RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaqp2rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaqp2rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaqp2rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+*     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+*     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+*     $                     INFO )
+*      IMPLICIT NONE
+*
+*     .. Scalar Arguments ..
+*      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+*      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            JPIV( * )
+*      REAL               A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+*     $                   WORK( * )
+*       ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> SLAQP2RK computes a truncated (rank K) or full rank Householder QR
+*> factorization with column pivoting of a real matrix
+*> block A(IOFFSET+1:M,1:N) as
+*>
+*>   A * P(K) = Q(K) * R(K).
+*>
+*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N)
+*> is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides matrix block B
+*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] KMAX
+*> \verbatim
+*>          KMAX is INTEGER
+*>
+*>          The first factorization stopping criterion. KMAX >= 0.
+*>
+*>          The maximum number of columns of the matrix A to factorize,
+*>          i.e. the maximum factorization rank.
+*>
+*>          a) If KMAX >= min(M-IOFFSET,N), then this stopping
+*>                criterion is not used, factorize columns
+*>                depending on ABSTOL and RELTOL.
+*>
+*>          b) If KMAX = 0, then this stopping criterion is
+*>             satisfied on input and the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The second factorization stopping criterion.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The third factorization stopping criterion.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine SGEQP3RK. 1 <= KP1 <= N_orig_mat.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is DOUBLE PRECISION
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine SGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is REAL array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:K) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(K) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:K) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,K+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(K)**T.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] K
+*> \verbatim
+*>          K is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N).
+*>
+*>          K also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is DOUBLE PRECISION
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank K. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is DOUBLE PRECISION
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank K) to the maximum column 2-norm of the
+*>          whole original matrix A. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is REAL array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is REAL array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is REAL array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is REAL array, dimension (N-1)
+*>          Used in SLARF subroutine to apply an elementary
+*>          reflector from the left.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step K+1 ( when K columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             K                  is set to the number of
+*>                                   factorized columns without
+*>                                   exception.
+*>             MAXC2NRMK          is set to NaN.
+*>             RELMAXC2NRMK       is set to NaN.
+*>             TAU(K+1:min(M,N))  is not set and contains undefined
+*>                                   elements. If j_1=K+1, TAU(K+1)
+*>                                   may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the factorization
+*>             step K+1 ( when K columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp2rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+     $                     INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPIV( * )
+      REAL               A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+     $                   WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
+     $                   MINMNUPDT
+      REAL               AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFG, SSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            SISNAN
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SNRM2
+      EXTERNAL           SISNAN, SLAMCH, ISAMAX, SNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+*     MINMNUPDT is the smallest dimension
+*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which
+*     contains the submatrices A(IOFFSET+1:M,1:N) and
+*     B(IOFFSET+1:M,1:NRHS) as column blocks.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      KMAX = MIN( KMAX, MINMNFACT )
+      TOL3Z = SQRT( SLAMCH( 'Epsilon' ) )
+      HUGEVAL = SLAMCH( 'Overflow' )
+*
+*     Compute the factorization, KK is the lomn loop index.
+*
+      DO KK = 1, KMAX
+*
+         I = IOFFSET + KK
+*
+         IF( I.EQ.1 ) THEN
+*
+*           ============================================================
+*
+*           We are at the first column of the original whole matrix A,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+
+            KP = KP1
+*
+*           ============================================================
+*
+         ELSE
+*
+*           ============================================================
+*
+*           Determine the pivot column in KK-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( KK-1 ) + ISAMAX( N-KK+1, VN1( KK ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,KK:N) in step KK.
+*           RELMAXC2NRMK  will be computed later, after somecondition
+*           checks on MAXC2NRMK.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains NaN, and set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( SISNAN( MAXC2NRMK ) ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+                K = KK - 1
+                INFO = K + KP
+*
+*               Set RELMAXC2NRMK to NaN.
+*
+                RELMAXC2NRMK = MAXC2NRMK
+*
+*               Array TAU(K+1:MINMNFACT) is not set and contains
+*               undefined elements.
+*
+               RETURN
+            END IF
+*
+*           ============================================================
+*
+*           Quick return, if the submatrix A(I:M,KK:N) is
+*           a zero matrix.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+               K = KK - 1
+               RELMAXC2NRMK = ZERO
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + KK - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third stopping criteria.
+*           NOTE: There is no need to test for ABSTOL >= ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+*              Set K, the number of factorized columns.
+*
+               K = KK - 1
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,KK:N):
+*        1) swap the KK-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) copy the KK-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than KK in the next loop step.)
+*        3) Save the pivot interchange with the indices relative to the
+*           the original matrix A, not the block A(1:M,1:N).
+*
+         IF( KP.NE.KK ) THEN
+            CALL SSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 )
+            VN1( KP ) = VN1( KK )
+            VN2( KP ) = VN2( KK )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( KK )
+            JPIV( KK ) = ITEMP
+         END IF
+*
+*        Generate elementary reflector H(KK) using the column A(I:M,KK),
+*        if the column has more than one element, otherwise
+*        the elementary reflector would be an identity matrix,
+*        and TAU(KK) = ZERO.
+*
+         IF( I.LT.M ) THEN
+            CALL SLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1,
+     $                   TAU( KK ) )
+         ELSE
+            TAU( KK ) = ZERO
+         END IF
+*
+*        Check if TAU(KK) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(KK) for Inf,
+*        since SLARFG cannot produce TAU(KK) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by SLARFG can contain Inf, which requires
+*        TAU(KK) to contain NaN. Therefore, this case of generating Inf
+*        by SLARFG is covered by checking TAU(KK) for NaN.
+*
+         IF( SISNAN( TAU(KK) ) ) THEN
+            K = KK - 1
+            INFO = KK
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAU( KK )
+            RELMAXC2NRMK = TAU( KK )
+*
+*           Array TAU(KK:MINMNFACT) is not set and contains
+*           undefined elements, except the first element TAU(KK) = NaN.
+*
+            RETURN
+         END IF
+*
+*        Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left.
+*        ( If M >= N, then at KK = N there is no residual matrix,
+*         i.e. no columns of A to update, only columns of B.
+*         If M < N, then at KK = M-IOFFSET, I = M and we have a
+*         one-row residual matrix in A and the elementary
+*         reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update
+*         is needed for the residual matrix in A and the
+*         right-hand-side-matrix in B.
+*         Therefore, we update only if
+*         KK < MINMNUPDT = min(M-IOFFSET, N+NRHS)
+*         condition is satisfied, not only KK < N+NRHS )
+*
+         IF( KK.LT.MINMNUPDT ) THEN
+            AIKK = A( I, KK )
+            A( I, KK ) = ONE
+            CALL SLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+     $                  TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) )
+            A( I, KK ) = AIKK
+         END IF
+*
+         IF( KK.LT.MINMNFACT ) THEN
+*
+*           Update the partial column 2-norms for the residual matrix,
+*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e.
+*           when KK < min(M-IOFFSET, N).
+*
+            DO J = KK + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2
+                  TEMP = MAX( TEMP, ZERO )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN
+*
+*                    Compute the column 2-norm for the partial
+*                    column A(I+1:M,J) by explicitly computing it,
+*                    and store it in both partial 2-norm vector VN1
+*                    and exact column 2-norm vector VN2.
+*
+                     VN1( J ) = SNRM2( M-I, A( I+1, J ), 1 )
+                     VN2( J ) = VN1( J )
+*
+                  ELSE
+*
+*                    Update the column 2-norm for the partial
+*                    column A(I+1:M,J) by removing one
+*                    element A(I,J) and store it in partial
+*                    2-norm vector VN1.
+*
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+*
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*     End factorization loop
+*
+      END DO
+*
+*     If we reached this point, all colunms have been factorized,
+*     i.e. no condition was triggered to exit the routine.
+*     Set the number of factorized columns.
+*
+      K = KMAX
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
+*     we return.
+*
+      IF( K.LT.MINMNFACT ) THEN
+*
+         JMAXC2NRM = K + ISAMAX( N-K, VN1( K+1 ), 1 )
+         MAXC2NRMK = VN1( JMAXC2NRM )
+*
+         IF( K.EQ.0 ) THEN
+            RELMAXC2NRMK = ONE
+         ELSE
+            RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM
+         END IF
+*
+      ELSE
+         MAXC2NRMK = ZERO
+         RELMAXC2NRMK = ZERO
+      END IF
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, set TAUs corresponding to the columns that were
+*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO.
+*
+      DO J = K + 1, MINMNFACT
+         TAU( J ) = ZERO
+      END DO
+*
+      RETURN
+*
+*     End of SLAQP2RK
+*
+      END

lapack-netlib/SRC/slaqp3rk.f

@@ -0,0 +1,935 @@
+*> \brief \b SLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SLAQP3RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaqp3rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaqp3rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaqp3rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE SLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+*     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+*     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+*     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+*      IMPLICIT NONE
+*      LOGICAL            DONE
+*      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+*     $                   NB, NRHS
+*      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*
+*     .. Scalar Arguments ..
+*      LOGICAL            DONE
+*      INTEGER            KB, LDA, LDF, M, N, NB, NRHS, IOFFSET
+*      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            IWORK( * ), JPIV( * )
+*      REAL               A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+*     $                   VN1( * ), VN2( * )
+*     ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> SLAQP3RK computes a step of truncated QR factorization with column
+*> pivoting of a real M-by-N matrix A block A(IOFFSET+1:M,1:N)
+*> by using Level 3 BLAS as
+*>
+*>   A * P(KB) = Q(KB) * R(KB).
+*>
+*> The routine tries to factorize NB columns from A starting from
+*> the row IOFFSET+1 and updates the residual matrix with BLAS 3
+*> xGEMM. The number of actually factorized columns is returned
+*> is smaller than NB.
+*>
+*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides B matrix stored
+*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**T * B.
+*>
+*> Cases when the number of factorized columns KB < NB:
+*>
+*> (1) In some cases, due to catastrophic cancellations, it cannot
+*> factorize all NB columns and need to update the residual matrix.
+*> Hence, the actual number of factorized columns in the block returned
+*> in KB is smaller than NB. The logical DONE is returned as FALSE.
+*> The factorization of the whole original matrix A_orig must proceed
+*> with the next block.
+*>
+*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB.
+*>
+*> (3) In case both stopping criteria ABSTOL or RELTOL are not used,
+*> and when the residual matrix is a zero matrix in some factorization
+*> step KB, the factorization of the whole original matrix A_orig is
+*> stopped, the logical DONE is returned as TRUE. The number of
+*> factorized columns which is smaller than NB is returned in KB.
+*>
+*> (4) Whenever NaN is detected in the matrix A or in the array TAU,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB. The INFO
+*> parameter is set to the column index of the first NaN occurrence.
+*>
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*>          NB is INTEGER
+*>          Factorization block size, i.e the number of columns
+*>          to factorize in the matrix A. 0 <= NB
+*>
+*>          If NB = 0, then the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is REAL, cannot be NaN.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is REAL, cannot be NaN.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine SGEQP3RK. 1 <= KP1 <= N_orig.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is REAL
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine SGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is REAL array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:KB) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(KB) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:KB) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,KB+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(KB)**T.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out]
+*> \verbatim
+*>          DONE is LOGICAL
+*>          TRUE: a) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to ABSTOL
+*>                   or RELTOL criterion,
+*>                b) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to the
+*>                   residual matrix being a ZERO matrix.
+*>                c) when NaN was detected in the matrix A
+*>                   or in the array TAU.
+*>          FALSE: otherwise.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*>          KB is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R.  0 <= KB <= min(M-IOFFSET,NB,N).
+*>
+*>          KB also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is REAL
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank KB. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is REAL
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank KB) to the maximum column 2-norm of the
+*>          original matrix A_orig. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is REAL array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is REAL array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is REAL array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] AUXV
+*> \verbatim
+*>          AUXV is REAL array, dimension (NB)
+*>          Auxiliary vector.
+*> \endverbatim
+*>
+*> \param[out] F
+*> \verbatim
+*>          F is REAL array, dimension (LDF,NB)
+*>          Matrix F**T = L*(Y**T)*A.
+*> \endverbatim
+*>
+*> \param[in] LDF
+*> \verbatim
+*>          LDF is INTEGER
+*>          The leading dimension of the array F. LDF >= max(1,N+NRHS).
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*>          IWORK is INTEGER array, dimension (N-1).
+*>          Is a work array. ( IWORK is used to store indices
+*>          of "bad" columns for norm downdating in the residual
+*>          matrix ).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step KB+1 ( when KB columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             KB                  is set to the number of
+*>                                    factorized columns without
+*>                                    exception.
+*>             MAXC2NRMK           is set to NaN.
+*>             RELMAXC2NRMK        is set to NaN.
+*>             TAU(KB+1:min(M,N))     is not set and contains undefined
+*>                                    elements. If j_1=KB+1, TAU(KB+1)
+*>                                    may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the actorization
+*>             step KB+1 ( when KB columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp3rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE SLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      LOGICAL            DONE
+      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+     $                   NB, NRHS
+      REAL               ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * ), JPIV( * )
+      REAL               A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+     $                   VN1( * ), VN2( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITEMP, J, K, MINMNFACT, MINMNUPDT,
+     $                   LSTICC, KP, I, IF
+      REAL               AIK, HUGEVAL, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SGEMV, SLARFG, SSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            SISNAN
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SNRM2
+      EXTERNAL           SISNAN, SLAMCH, ISAMAX, SNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      NB = MIN( NB, MINMNFACT )
+      TOL3Z = SQRT( SLAMCH( 'Epsilon' ) )
+      HUGEVAL = SLAMCH( 'Overflow' )
+*
+*     Compute factorization in a while loop over NB columns,
+*     K is the column index in the block A(1:M,1:N).
+*
+      K = 0
+      LSTICC = 0
+      DONE = .FALSE.
+*
+      DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 )
+         K = K + 1
+         I = IOFFSET + K
+*
+         IF( I.EQ.1 ) THEN
+*
+*           We are at the first column of the original whole matrix A_orig,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+            KP = KP1
+*
+         ELSE
+*
+*           Determine the pivot column in K-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,K:N) in step K.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains NaN, set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( SISNAN( MAXC2NRMK ) ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               INFO = KB + KP
+*
+*              Set RELMAXC2NRMK to NaN.
+*
+               RELMAXC2NRMK = MAXC2NRMK
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix contains NaN and we stop
+*              the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T.
+
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                  M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Array TAU(KF+1:MINMNFACT) is not set and contains
+*              undefined elements.
+*
+*              Return from the routine.
+*
+               RETURN
+            END IF
+*
+*           Quick return, if the submatrix A(I:M,K:N) is
+*           a zero matrix. We need to check it only if the column index
+*           (same as row index) is larger than 1, since the condition
+*           for the whole original matrix A_orig is checked in the main
+*           routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               RELMAXC2NRMK = ZERO
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix is zero and we stop the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T.
+*
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                  M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = ZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + K - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third tolerance stopping criteria.
+*           NOTE: There is no need to test for ABSTOL.GE.ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig;
+*
+                  KB = K - 1
+                  IF = I - 1
+*
+*              Apply the block reflector to the residual of the
+*              matrix A and the residual of the right hand sides B, if
+*              the residual matrix and and/or the residual of the right
+*              hand sides exist,  i.e. if the submatrix
+*              A(I+1:M,KB+1:N+NRHS) exists.  This occurs when
+*                 KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*              A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                             A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T.
+*
+               IF( KB.LT.MINMNUPDT ) THEN
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                  M-IF, N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA,
+     $                  F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = ZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = ZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,K:N):
+*        1) swap the K-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) swap the K-th row and the KP-th row in F(1:N,1:K-1)
+*        3) copy the K-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. (Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than K in the next loop step.)
+*        4) Save the pivot interchange with the indices relative to the
+*           the original matrix A_orig, not the block A(1:M,1:N).
+*
+         IF( KP.NE.K ) THEN
+            CALL SSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 )
+            CALL SSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF )
+            VN1( KP ) = VN1( K )
+            VN2( KP ) = VN2( K )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( K )
+            JPIV( K ) = ITEMP
+         END IF
+*
+*        Apply previous Householder reflectors to column K:
+*        A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T.
+*
+         IF( K.GT.1 ) THEN
+            CALL SGEMV( 'No transpose', M-I+1, K-1, -ONE, A( I, 1 ),
+     $                  LDA, F( K, 1 ), LDF, ONE, A( I, K ), 1 )
+         END IF
+*
+*        Generate elementary reflector H(k) using the column A(I:M,K).
+*
+         IF( I.LT.M ) THEN
+            CALL SLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) )
+         ELSE
+            TAU( K ) = ZERO
+         END IF
+*
+*        Check if TAU(K) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(K) for Inf,
+*        since SLARFG cannot produce TAU(K) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by SLARFG can contain Inf, which requires
+*        TAU(K) to contain NaN. Therefore, this case of generating Inf
+*        by SLARFG is covered by checking TAU(K) for NaN.
+*
+         IF( SISNAN( TAU(K) ) ) THEN
+*
+            DONE = .TRUE.
+*
+*           Set KB, the number of factorized partial columns
+*                   that are non-zero in each step in the block,
+*                   i.e. the rank of the factor R.
+*           Set IF, the number of processed rows in the block, which
+*                   is the same as the number of processed rows in
+*                   the original whole matrix A_orig.
+*
+            KB = K - 1
+            IF = I - 1
+            INFO = K
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAU( K )
+            RELMAXC2NRMK = TAU( K )
+*
+*           There is no need to apply the block reflector to the
+*           residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*           since the submatrix contains NaN and we stop
+*           the computation.
+*           But, we need to apply the block reflector to the residual
+*           right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*           residual right hand sides exist.  This occurs
+*           when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*           A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                            A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T.
+*
+            IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+               CALL SGEMM( 'No transpose', 'Transpose',
+     $               M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA,
+     $               F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA )
+            END IF
+*
+*           There is no need to recompute the 2-norm of the
+*           difficult columns, since we stop the factorization.
+*
+*           Array TAU(KF+1:MINMNFACT) is not set and contains
+*           undefined elements.
+*
+*           Return from the routine.
+*
+            RETURN
+         END IF
+*
+*        ===============================================================
+*
+         AIK = A( I, K )
+         A( I, K ) = ONE
+*
+*        ===============================================================
+*
+*        Compute the current K-th column of F:
+*          1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K).
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL SGEMV( 'Transpose', M-I+1, N+NRHS-K,
+     $                  TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1,
+     $                  ZERO, F( K+1, K ), 1 )
+         END IF
+*
+*           2) Zero out elements above and on the diagonal of the
+*              column K in matrix F, i.e elements F(1:K,K).
+*
+         DO J = 1, K
+            F( J, K ) = ZERO
+         END DO
+*
+*         3) Incremental updating of the K-th column of F:
+*        F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T
+*                    * A(I:M,K).
+*
+         IF( K.GT.1 ) THEN
+            CALL SGEMV( 'Transpose', M-I+1, K-1, -TAU( K ),
+     $                  A( I, 1 ), LDA, A( I, K ), 1, ZERO,
+     $                  AUXV( 1 ), 1 )
+*
+            CALL SGEMV( 'No transpose', N+NRHS, K-1, ONE,
+     $                  F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE,
+     $                  F( 1, K ), 1 )
+         END IF
+*
+*        ===============================================================
+*
+*        Update the current I-th row of A:
+*        A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS)
+*                         - A(I,1:K)*F(K+1:N+NRHS,1:K)**T.
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL SGEMV( 'No transpose', N+NRHS-K, K, -ONE,
+     $                  F( K+1, 1 ), LDF, A( I, 1 ), LDA, ONE,
+     $                  A( I, K+1 ), LDA )
+         END IF
+*
+         A( I, K ) = AIK
+*
+*        Update the partial column 2-norms for the residual matrix,
+*        only if the residual matrix A(I+1:M,K+1:N) exists, i.e.
+*        when K < MINMNFACT = min( M-IOFFSET, N ).
+*
+         IF( K.LT.MINMNFACT ) THEN
+*
+            DO J = K + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ABS( A( I, J ) ) / VN1( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2.LE.TOL3Z ) THEN
+*
+*                    At J-index, we have a difficult column for the
+*                    update of the 2-norm. Save the index of the previous
+*                    difficult column in IWORK(J-1).
+*                    NOTE: ILSTCC > 1, threfore we can use IWORK only
+*                    with N-1 elements, where the elements are
+*                    shifted by 1 to the left.
+*
+                     IWORK( J-1 ) = LSTICC
+*
+*                    Set the index of the last difficult column LSTICC.
+*
+                     LSTICC = J
+*
+                  ELSE
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*        End of while loop.
+*
+      END DO
+*
+*     Now, afler the loop:
+*        Set KB, the number of factorized columns in the block;
+*        Set IF, the number of processed rows in the block, which
+*                is the same as the number of processed rows in
+*                the original whole matrix A_orig, IF = IOFFSET + KB.
+*
+      KB = K
+      IF = I
+*
+*     Apply the block reflector to the residual of the matrix A
+*     and the residual of the right hand sides B, if the residual
+*     matrix and and/or the residual of the right hand sides
+*     exist,  i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists.
+*     This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*     A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                         A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T.
+*
+      IF( KB.LT.MINMNUPDT ) THEN
+         CALL SGEMM( 'No transpose', 'Transpose',
+     $         M-IF, N+NRHS-KB, KB, -ONE, A( IF+1, 1 ), LDA,
+     $         F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA )
+      END IF
+*
+*     Recompute the 2-norm of the difficult columns.
+*     Loop over the index of the difficult columns from the largest
+*     to the smallest index.
+*
+      DO WHILE( LSTICC.GT.0 )
+*
+*        LSTICC is the index of the last difficult column is greater
+*        than 1.
+*        ITEMP is the index of the previous difficult column.
+*
+         ITEMP = IWORK( LSTICC-1 )
+*
+*        Compute the 2-norm explicilty for the last difficult column and
+*        save it in the partial and exact 2-norm vectors VN1 and VN2.
+*
+*        NOTE: The computation of VN1( LSTICC ) relies on the fact that
+*        SNRM2 does not fail on vectors with norm below the value of
+*        SQRT(SLAMCH('S'))
+*
+         VN1( LSTICC ) = SNRM2( M-IF, A( IF+1, LSTICC ), 1 )
+         VN2( LSTICC ) = VN1( LSTICC )
+*
+*        Downdate the index of the last difficult column to
+*        the index of the previous difficult column.
+*
+         LSTICC = ITEMP
+*
+      END DO
+*
+      RETURN
+*
+*     End of SLAQP3RK
+*
+      END

lapack-netlib/SRC/zlaqp2rk.c

@@ -0,0 +1,947 @@
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) {ceil(w)}
+#define myhuge_(w) {HUGE_VAL}
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+	complex pow={1.0,0.0}; unsigned long int u;
+		if(n != 0) {
+		if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+		for(u = n; ; ) {
+			if(u & 01) pow.r *= x.r, pow.i *= x.i;
+			if(u >>= 1) x.r *= x.r, x.i *= x.i;
+			else break;
+		}
+	}
+	_Fcomplex p={pow.r, pow.i};
+	return p;
+}
+#else
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+	_Dcomplex pow={1.0,0.0}; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+		for(u = n; ; ) {
+			if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+			if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+			else break;
+		}
+	}
+	_Dcomplex p = {pow._Val[0], pow._Val[1]};
+	return p;
+}
+#else
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+#endif
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Fcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+			zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+		}
+	}
+	pCf(z) = zdotc;
+}
+#else
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+	_Dcomplex zdotc = {0.0, 0.0};
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+			zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+			zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+		}
+	}
+	pCd(z) = zdotc;
+}
+#else
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaqp2rk_(integer *m, integer *n, integer *nrhs, integer 
+	*ioffset, integer *kmax, doublereal *abstol, doublereal *reltol, 
+	integer *kp1, doublereal *maxc2nrm, doublecomplex *a, integer *lda, 
+	integer *k, doublereal *maxc2nrmk, doublereal *relmaxc2nrmk, integer *
+	jpiv, doublecomplex *tau, doublereal *vn1, doublereal *vn2, 
+	doublecomplex *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1;
+    doublecomplex z__1;
+
+    /* Local variables */
+    doublecomplex aikk;
+    doublereal temp, temp2;
+    integer i__, j;
+    doublereal tol3z;
+    integer jmaxc2nrm, itemp;
+    extern /* Subroutine */ int zlarf_(char *, integer *, integer *, 
+	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
+	    integer *, doublecomplex *);
+    integer minmnfact;
+    extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *);
+    doublereal myhugeval;
+    integer minmnupdt;
+    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+    integer kk;
+    extern doublereal dlamch_(char *);
+    integer kp;
+    extern integer idamax_(integer *, doublereal *, integer *);
+    extern logical disnan_(doublereal *);
+    extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *);
+    doublereal taunan;
+
+
+/*  -- LAPACK auxiliary routine -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/*  ===================================================================== */
+
+
+/*     Initialize INFO */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpiv;
+    --tau;
+    --vn1;
+    --vn2;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+
+/*     MINMNFACT in the smallest dimension of the submatrix */
+/*     A(IOFFSET+1:M,1:N) to be factorized. */
+
+/*     MINMNUPDT is the smallest dimension */
+/*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which */
+/*     contains the submatrices A(IOFFSET+1:M,1:N) and */
+/*     B(IOFFSET+1:M,1:NRHS) as column blocks. */
+
+/* Computing MIN */
+    i__1 = *m - *ioffset;
+    minmnfact = f2cmin(i__1,*n);
+/* Computing MIN */
+    i__1 = *m - *ioffset, i__2 = *n + *nrhs;
+    minmnupdt = f2cmin(i__1,i__2);
+    *kmax = f2cmin(*kmax,minmnfact);
+    tol3z = sqrt(dlamch_("Epsilon"));
+    myhugeval = dlamch_("Overflow");
+
+/*     Compute the factorization, KK is the lomn loop index. */
+
+    i__1 = *kmax;
+    for (kk = 1; kk <= i__1; ++kk) {
+
+	i__ = *ioffset + kk;
+
+	if (i__ == 1) {
+
+/*           ============================================================ */
+
+/*           We are at the first column of the original whole matrix A, */
+/*           therefore we use the computed KP1 and MAXC2NRM from the */
+/*           main routine. */
+
+	    kp = *kp1;
+
+/*           ============================================================ */
+
+	} else {
+
+/*           ============================================================ */
+
+/*           Determine the pivot column in KK-th step, i.e. the index */
+/*           of the column with the maximum 2-norm in the */
+/*           submatrix A(I:M,K:N). */
+
+	    i__2 = *n - kk + 1;
+	    kp = kk - 1 + idamax_(&i__2, &vn1[kk], &c__1);
+
+/*           Determine the maximum column 2-norm and the relative maximum */
+/*           column 2-norm of the submatrix A(I:M,KK:N) in step KK. */
+/*           RELMAXC2NRMK  will be computed later, after somecondition */
+/*           checks on MAXC2NRMK. */
+
+	    *maxc2nrmk = vn1[kp];
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains NaN, and set */
+/*           INFO parameter to the column number, where the first NaN */
+/*           is found and return from the routine. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (disnan_(maxc2nrmk)) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*info = *k + kp;
+
+/*               Set RELMAXC2NRMK to NaN. */
+
+		*relmaxc2nrmk = *maxc2nrmk;
+
+/*               Array TAU(K+1:MINMNFACT) is not set and contains */
+/*               undefined elements. */
+
+		return 0;
+	    }
+
+/*           ============================================================ */
+
+/*           Quick return, if the submatrix A(I:M,KK:N) is */
+/*           a zero matrix. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*maxc2nrmk == 0.) {
+
+/*              Set K, the number of factorized columns. */
+/*              that are not zero. */
+
+		*k = kk - 1;
+		*relmaxc2nrmk = 0.;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    i__3 = j;
+		    tau[i__3].r = 0., tau[i__3].i = 0.;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           Check if the submatrix A(I:M,KK:N) contains Inf, */
+/*           set INFO parameter to the column number, where */
+/*           the first Inf is found plus N, and continue */
+/*           the computation. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+
+	    if (*info == 0 && *maxc2nrmk > myhugeval) {
+		*info = *n + kk - 1 + kp;
+	    }
+
+/*           ============================================================ */
+
+/*           Test for the second and third stopping criteria. */
+/*           NOTE: There is no need to test for ABSTOL >= ZERO, since */
+/*           MAXC2NRMK is non-negative. Similarly, there is no need */
+/*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is */
+/*           non-negative. */
+/*           We need to check the condition only if the */
+/*           column index (same as row index) of the original whole */
+/*           matrix is larger than 1, since the condition for whole */
+/*           original matrix is checked in the main routine. */
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+
+	    if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) {
+
+/*              Set K, the number of factorized columns. */
+
+		*k = kk - 1;
+
+/*              Set TAUs corresponding to the columns that were not */
+/*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */
+
+		i__2 = minmnfact;
+		for (j = kk; j <= i__2; ++j) {
+		    i__3 = j;
+		    tau[i__3].r = 0., tau[i__3].i = 0.;
+		}
+
+/*              Return from the routine. */
+
+		return 0;
+
+	    }
+
+/*           ============================================================ */
+
+/*           End ELSE of IF(I.EQ.1) */
+
+	}
+
+/*        =============================================================== */
+
+/*        If the pivot column is not the first column of the */
+/*        subblock A(1:M,KK:N): */
+/*        1) swap the KK-th column and the KP-th pivot column */
+/*           in A(1:M,1:N); */
+/*        2) copy the KK-th element into the KP-th element of the partial */
+/*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */
+/*           for VN1 and VN2 since we use the element with the index */
+/*           larger than KK in the next loop step.) */
+/*        3) Save the pivot interchange with the indices relative to the */
+/*           the original matrix A, not the block A(1:M,1:N). */
+
+	if (kp != kk) {
+	    zswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1);
+	    vn1[kp] = vn1[kk];
+	    vn2[kp] = vn2[kk];
+	    itemp = jpiv[kp];
+	    jpiv[kp] = jpiv[kk];
+	    jpiv[kk] = itemp;
+	}
+
+/*        Generate elementary reflector H(KK) using the column A(I:M,KK), */
+/*        if the column has more than one element, otherwise */
+/*        the elementary reflector would be an identity matrix, */
+/*        and TAU(KK) = CZERO. */
+
+	if (i__ < *m) {
+	    i__2 = *m - i__ + 1;
+	    zlarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], &
+		    c__1, &tau[kk]);
+	} else {
+	    i__2 = kk;
+	    tau[i__2].r = 0., tau[i__2].i = 0.;
+	}
+
+/*        Check if TAU(KK) contains NaN, set INFO parameter */
+/*        to the column number where NaN is found and return from */
+/*        the routine. */
+/*        NOTE: There is no need to check TAU(KK) for Inf, */
+/*        since ZLARFG cannot produce TAU(KK) or Householder vector */
+/*        below the diagonal containing Inf. Only BETA on the diagonal, */
+/*        returned by ZLARFG can contain Inf, which requires */
+/*        TAU(KK) to contain NaN. Therefore, this case of generating Inf */
+/*        by ZLARFG is covered by checking TAU(KK) for NaN. */
+
+	i__2 = kk;
+	d__1 = tau[i__2].r;
+	if (disnan_(&d__1)) {
+	    i__2 = kk;
+	    taunan = tau[i__2].r;
+	} else /* if(complicated condition) */ {
+	    d__1 = d_imag(&tau[kk]);
+	    if (disnan_(&d__1)) {
+		taunan = d_imag(&tau[kk]);
+	    } else {
+		taunan = 0.;
+	    }
+	}
+
+	if (disnan_(&taunan)) {
+	    *k = kk - 1;
+	    *info = kk;
+
+/*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN. */
+
+	    *maxc2nrmk = taunan;
+	    *relmaxc2nrmk = taunan;
+
+/*           Array TAU(KK:MINMNFACT) is not set and contains */
+/*           undefined elements, except the first element TAU(KK) = NaN. */
+
+	    return 0;
+	}
+
+/*        Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. */
+/*        ( If M >= N, then at KK = N there is no residual matrix, */
+/*         i.e. no columns of A to update, only columns of B. */
+/*         If M < N, then at KK = M-IOFFSET, I = M and we have a */
+/*         one-row residual matrix in A and the elementary */
+/*         reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update */
+/*         is needed for the residual matrix in A and the */
+/*         right-hand-side-matrix in B. */
+/*         Therefore, we update only if */
+/*         KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */
+/*         condition is satisfied, not only KK < N+NRHS ) */
+
+	if (kk < minmnupdt) {
+	    i__2 = i__ + kk * a_dim1;
+	    aikk.r = a[i__2].r, aikk.i = a[i__2].i;
+	    i__2 = i__ + kk * a_dim1;
+	    a[i__2].r = 1., a[i__2].i = 0.;
+	    i__2 = *m - i__ + 1;
+	    i__3 = *n + *nrhs - kk;
+	    d_cnjg(&z__1, &tau[kk]);
+	    zlarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &z__1, 
+		    &a[i__ + (kk + 1) * a_dim1], lda, &work[1]);
+	    i__2 = i__ + kk * a_dim1;
+	    a[i__2].r = aikk.r, a[i__2].i = aikk.i;
+	}
+
+	if (kk < minmnfact) {
+
+/*           Update the partial column 2-norms for the residual matrix, */
+/*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */
+/*           when KK < f2cmin(M-IOFFSET, N). */
+
+	    i__2 = *n;
+	    for (j = kk + 1; j <= i__2; ++j) {
+		if (vn1[j] != 0.) {
+
+/*                 NOTE: The following lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+/* Computing 2nd power */
+		    d__1 = z_abs(&a[i__ + j * a_dim1]) / vn1[j];
+		    temp = 1. - d__1 * d__1;
+		    temp = f2cmax(temp,0.);
+/* Computing 2nd power */
+		    d__1 = vn1[j] / vn2[j];
+		    temp2 = temp * (d__1 * d__1);
+		    if (temp2 <= tol3z) {
+
+/*                    Compute the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by explicitly computing it, */
+/*                    and store it in both partial 2-norm vector VN1 */
+/*                    and exact column 2-norm vector VN2. */
+
+			i__3 = *m - i__;
+			vn1[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1], &
+				c__1);
+			vn2[j] = vn1[j];
+
+		    } else {
+
+/*                    Update the column 2-norm for the partial */
+/*                    column A(I+1:M,J) by removing one */
+/*                    element A(I,J) and store it in partial */
+/*                    2-norm vector VN1. */
+
+			vn1[j] *= sqrt(temp);
+
+		    }
+		}
+	    }
+
+	}
+
+/*     End factorization loop */
+
+    }
+
+/*     If we reached this point, all colunms have been factorized, */
+/*     i.e. no condition was triggered to exit the routine. */
+/*     Set the number of factorized columns. */
+
+    *k = *kmax;
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */
+/*     we return. */
+
+    if (*k < minmnfact) {
+
+	i__1 = *n - *k;
+	jmaxc2nrm = *k + idamax_(&i__1, &vn1[*k + 1], &c__1);
+	*maxc2nrmk = vn1[jmaxc2nrm];
+
+	if (*k == 0) {
+	    *relmaxc2nrmk = 1.;
+	} else {
+	    *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm;
+	}
+
+    } else {
+	*maxc2nrmk = 0.;
+	*relmaxc2nrmk = 0.;
+    }
+
+/*     We reached the end of the loop, i.e. all KMAX columns were */
+/*     factorized, set TAUs corresponding to the columns that were */
+/*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. */
+
+    i__1 = minmnfact;
+    for (j = *k + 1; j <= i__1; ++j) {
+	i__2 = j;
+	tau[i__2].r = 0., tau[i__2].i = 0.;
+    }
+
+    return 0;
+
+/*     End of ZLAQP2RK */
+
+} /* zlaqp2rk_ */
+

lapack-netlib/SRC/zlaqp2rk.f

@@ -0,0 +1,726 @@
+*> \brief \b ZLAQP2RK computes truncated QR factorization with column pivoting of a complex matrix block using Level 2 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQP2RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqp2rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqp2rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqp2rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+*     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+*     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+*     $                     INFO )
+*      IMPLICIT NONE
+*
+*     .. Scalar Arguments ..
+*      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+*      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            JPIV( * )
+*      DOUBLE PRECISION   VN1( * ), VN2( * )
+*      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     $
+*       ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> ZLAQP2RK computes a truncated (rank K) or full rank Householder QR
+*> factorization with column pivoting of the complex matrix
+*> block A(IOFFSET+1:M,1:N) as
+*>
+*>   A * P(K) = Q(K) * R(K).
+*>
+*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N)
+*> is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides matrix block B
+*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**H * B.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] KMAX
+*> \verbatim
+*>          KMAX is INTEGER
+*>
+*>          The first factorization stopping criterion. KMAX >= 0.
+*>
+*>          The maximum number of columns of the matrix A to factorize,
+*>          i.e. the maximum factorization rank.
+*>
+*>          a) If KMAX >= min(M-IOFFSET,N), then this stopping
+*>                criterion is not used, factorize columns
+*>                depending on ABSTOL and RELTOL.
+*>
+*>          b) If KMAX = 0, then this stopping criterion is
+*>             satisfied on input and the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The second factorization stopping criterion.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The third factorization stopping criterion.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on KMAX and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine ZGEQP3RK. 1 <= KP1 <= N_orig_mat.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is DOUBLE PRECISION
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine ZGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is COMPLEX*16 array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:K) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(K) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:K) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,K+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(K)**H.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] K
+*> \verbatim
+*>          K is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N).
+*>
+*>          K also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is DOUBLE PRECISION
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank K. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is DOUBLE PRECISION
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank K) to the maximum column 2-norm of the
+*>          whole original matrix A. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is COMPLEX*16 array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is COMPLEX*16 array, dimension (N-1)
+*>          Used in ZLARF subroutine to apply an elementary
+*>          reflector from the left.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step K+1 ( when K columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             K                  is set to the number of
+*>                                   factorized columns without
+*>                                   exception.
+*>             MAXC2NRMK          is set to NaN.
+*>             RELMAXC2NRMK       is set to NaN.
+*>             TAU(K+1:min(M,N))  is not set and contains undefined
+*>                                   elements. If j_1=K+1, TAU(K+1)
+*>                                   may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the factorization
+*>             step K+1 ( when K columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp2rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
+     $                     KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK,
+     $                     RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK,
+     $                     INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS
+      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPIV( * )
+      DOUBLE PRECISION   VN1( * ), VN2( * )
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. 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, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
+     $                   MINMNUPDT
+      DOUBLE PRECISION   HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z
+      COMPLEX*16         AIKK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLARF, ZLARFG, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            DISNAN
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DZNRM2
+      EXTERNAL           DISNAN, DLAMCH, IDAMAX, DZNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+*     MINMNUPDT is the smallest dimension
+*     of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which
+*     contains the submatrices A(IOFFSET+1:M,1:N) and
+*     B(IOFFSET+1:M,1:NRHS) as column blocks.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      KMAX = MIN( KMAX, MINMNFACT )
+      TOL3Z = SQRT( DLAMCH( 'Epsilon' ) )
+      HUGEVAL = DLAMCH( 'Overflow' )
+*
+*     Compute the factorization, KK is the lomn loop index.
+*
+      DO KK = 1, KMAX
+*
+         I = IOFFSET + KK
+*
+         IF( I.EQ.1 ) THEN
+*
+*           ============================================================
+*
+*           We are at the first column of the original whole matrix A,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+            KP = KP1
+*
+*           ============================================================
+*
+         ELSE
+*
+*           ============================================================
+*
+*           Determine the pivot column in KK-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,KK:N) in step KK.
+*           RELMAXC2NRMK  will be computed later, after somecondition
+*           checks on MAXC2NRMK.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains NaN, and set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( DISNAN( MAXC2NRMK ) ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+                K = KK - 1
+                INFO = K + KP
+*
+*               Set RELMAXC2NRMK to NaN.
+*
+                RELMAXC2NRMK = MAXC2NRMK
+*
+*               Array TAU(K+1:MINMNFACT) is not set and contains
+*               undefined elements.
+*
+               RETURN
+            END IF
+*
+*           ============================================================
+*
+*           Quick return, if the submatrix A(I:M,KK:N) is
+*           a zero matrix.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+*              Set K, the number of factorized columns.
+*              that are not zero.
+*
+               K = KK - 1
+               RELMAXC2NRMK = ZERO
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,KK:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + KK - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third stopping criteria.
+*           NOTE: There is no need to test for ABSTOL >= ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL >= ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+*              Set K, the number of factorized columns.
+*
+               K = KK - 1
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO.
+*
+               DO J = KK, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,KK:N):
+*        1) swap the KK-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) copy the KK-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. ( Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than KK in the next loop step.)
+*        3) Save the pivot interchange with the indices relative to the
+*           the original matrix A, not the block A(1:M,1:N).
+*
+         IF( KP.NE.KK ) THEN
+            CALL ZSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 )
+            VN1( KP ) = VN1( KK )
+            VN2( KP ) = VN2( KK )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( KK )
+            JPIV( KK ) = ITEMP
+         END IF
+*
+*        Generate elementary reflector H(KK) using the column A(I:M,KK),
+*        if the column has more than one element, otherwise
+*        the elementary reflector would be an identity matrix,
+*        and TAU(KK) = CZERO.
+*
+         IF( I.LT.M ) THEN
+            CALL ZLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1,
+     $                   TAU( KK ) )
+         ELSE
+            TAU( KK ) = CZERO
+         END IF
+*
+*        Check if TAU(KK) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(KK) for Inf,
+*        since ZLARFG cannot produce TAU(KK) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by ZLARFG can contain Inf, which requires
+*        TAU(KK) to contain NaN. Therefore, this case of generating Inf
+*        by ZLARFG is covered by checking TAU(KK) for NaN.
+*
+         IF( DISNAN( DBLE( TAU(KK) ) ) ) THEN
+            TAUNAN = DBLE( TAU(KK) )
+         ELSE IF( DISNAN( DIMAG( TAU(KK) ) ) ) THEN
+            TAUNAN = DIMAG( TAU(KK) )
+         ELSE
+            TAUNAN = ZERO
+         END IF
+*
+         IF( DISNAN( TAUNAN ) ) THEN
+            K = KK - 1
+            INFO = KK
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAUNAN
+            RELMAXC2NRMK = TAUNAN
+*
+*           Array TAU(KK:MINMNFACT) is not set and contains
+*           undefined elements, except the first element TAU(KK) = NaN.
+*
+            RETURN
+         END IF
+*
+*        Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left.
+*        ( If M >= N, then at KK = N there is no residual matrix,
+*         i.e. no columns of A to update, only columns of B.
+*         If M < N, then at KK = M-IOFFSET, I = M and we have a
+*         one-row residual matrix in A and the elementary
+*         reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update
+*         is needed for the residual matrix in A and the
+*         right-hand-side-matrix in B.
+*         Therefore, we update only if
+*         KK < MINMNUPDT = min(M-IOFFSET, N+NRHS)
+*         condition is satisfied, not only KK < N+NRHS )
+*
+         IF( KK.LT.MINMNUPDT ) THEN
+            AIKK = A( I, KK )
+            A( I, KK ) = CONE
+            CALL ZLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+     $                  DCONJG( TAU( KK ) ), A( I, KK+1 ), LDA,
+     $                  WORK( 1 ) )
+            A( I, KK ) = AIKK
+         END IF
+*
+         IF( KK.LT.MINMNFACT ) THEN
+*
+*           Update the partial column 2-norms for the residual matrix,
+*           only if the residual matrix A(I+1:M,KK+1:N) exists, i.e.
+*           when KK < min(M-IOFFSET, N).
+*
+            DO J = KK + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2
+                  TEMP = MAX( TEMP, ZERO )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN
+*
+*                    Compute the column 2-norm for the partial
+*                    column A(I+1:M,J) by explicitly computing it,
+*                    and store it in both partial 2-norm vector VN1
+*                    and exact column 2-norm vector VN2.
+*
+                     VN1( J ) = DZNRM2( M-I, A( I+1, J ), 1 )
+                     VN2( J ) = VN1( J )
+*
+                  ELSE
+*
+*                    Update the column 2-norm for the partial
+*                    column A(I+1:M,J) by removing one
+*                    element A(I,J) and store it in partial
+*                    2-norm vector VN1.
+*
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+*
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*     End factorization loop
+*
+      END DO
+*
+*     If we reached this point, all colunms have been factorized,
+*     i.e. no condition was triggered to exit the routine.
+*     Set the number of factorized columns.
+*
+      K = KMAX
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
+*     we return.
+*
+      IF( K.LT.MINMNFACT ) THEN
+*
+         JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 )
+         MAXC2NRMK = VN1( JMAXC2NRM )
+*
+         IF( K.EQ.0 ) THEN
+            RELMAXC2NRMK = ONE
+         ELSE
+            RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM
+         END IF
+*
+      ELSE
+         MAXC2NRMK = ZERO
+         RELMAXC2NRMK = ZERO
+      END IF
+*
+*     We reached the end of the loop, i.e. all KMAX columns were
+*     factorized, set TAUs corresponding to the columns that were
+*     not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO.
+*
+      DO J = K + 1, MINMNFACT
+         TAU( J ) = CZERO
+      END DO
+*
+      RETURN
+*
+*     End of ZLAQP2RK
+*
+      END

lapack-netlib/SRC/zlaqp3rk.f

@@ -0,0 +1,947 @@
+*> \brief \b ZLAQP3RK computes a step of truncated QR factorization with column pivoting of a complex m-by-n matrix A using Level 3 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B.
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQP3RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqp3rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqp3rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqp3rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+*     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+*     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+*     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+*      IMPLICIT NONE
+*      LOGICAL            DONE
+*      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+*     $                   NB, NRHS
+*      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+*     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+*      INTEGER            IWORK( * ), JPIV( * )
+*      DOUBLE PRECISION   VN1( * ), VN2( * )
+*      COMPLEX*16         A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
+*     ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> ZLAQP3RK computes a step of truncated QR factorization with column
+*> pivoting of a complex M-by-N matrix A block A(IOFFSET+1:M,1:N)
+*> by using Level 3 BLAS as
+*>
+*>   A * P(KB) = Q(KB) * R(KB).
+*>
+*> The routine tries to factorize NB columns from A starting from
+*> the row IOFFSET+1 and updates the residual matrix with BLAS 3
+*> xGEMM. The number of actually factorized columns is returned
+*> is smaller than NB.
+*>
+*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized.
+*>
+*> The routine also overwrites the right-hand-sides B matrix stored
+*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**H * B.
+*>
+*> Cases when the number of factorized columns KB < NB:
+*>
+*> (1) In some cases, due to catastrophic cancellations, it cannot
+*> factorize all NB columns and need to update the residual matrix.
+*> Hence, the actual number of factorized columns in the block returned
+*> in KB is smaller than NB. The logical DONE is returned as FALSE.
+*> The factorization of the whole original matrix A_orig must proceed
+*> with the next block.
+*>
+*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB.
+*>
+*> (3) In case both stopping criteria ABSTOL or RELTOL are not used,
+*> and when the residual matrix is a zero matrix in some factorization
+*> step KB, the factorization of the whole original matrix A_orig is
+*> stopped, the logical DONE is returned as TRUE. The number of
+*> factorized columns which is smaller than NB is returned in KB.
+*>
+*> (4) Whenever NaN is detected in the matrix A or in the array TAU,
+*> the factorization of the whole original matrix A_orig is stopped,
+*> the logical DONE is returned as TRUE. The number of factorized
+*> columns which is smaller than NB is returned in KB. The INFO
+*> parameter is set to the column index of the first NaN occurrence.
+*>
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] M
+*> \verbatim
+*>          M is INTEGER
+*>          The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*>          N is INTEGER
+*>          The number of columns of the matrix A. N >= 0
+*> \endverbatim
+*>
+*> \param[in] 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] IOFFSET
+*> \verbatim
+*>          IOFFSET is INTEGER
+*>          The number of rows of the matrix A that must be pivoted
+*>          but not factorized. IOFFSET >= 0.
+*>
+*>          IOFFSET also represents the number of columns of the whole
+*>          original matrix A_orig that have been factorized
+*>          in the previous steps.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*>          NB is INTEGER
+*>          Factorization block size, i.e the number of columns
+*>          to factorize in the matrix A. 0 <= NB
+*>
+*>          If NB = 0, then the routine exits immediately.
+*>             This means that the factorization is not performed,
+*>             the matrices A and B and the arrays TAU, IPIV
+*>             are not modified.
+*> \endverbatim
+*>
+*> \param[in] ABSTOL
+*> \verbatim
+*>          ABSTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The absolute tolerance (stopping threshold) for
+*>          maximum column 2-norm of the residual matrix.
+*>          The algorithm converges (stops the factorization) when
+*>          the maximum column 2-norm of the residual matrix
+*>          is less than or equal to ABSTOL.
+*>
+*>          a) If ABSTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and RELTOL.
+*>                This includes the case ABSTOL = -Inf.
+*>
+*>          b) If 0.0 <= ABSTOL then the input value
+*>                of ABSTOL is used.
+*> \endverbatim
+*>
+*> \param[in] RELTOL
+*> \verbatim
+*>          RELTOL is DOUBLE PRECISION, cannot be NaN.
+*>
+*>          The tolerance (stopping threshold) for the ratio of the
+*>          maximum column 2-norm of the residual matrix to the maximum
+*>          column 2-norm of the original matrix A_orig. The algorithm
+*>          converges (stops the factorization), when this ratio is
+*>          less than or equal to RELTOL.
+*>
+*>          a) If RELTOL < 0.0, then this stopping criterion is not
+*>                used, the routine factorizes columns depending
+*>                on NB and ABSTOL.
+*>                This includes the case RELTOL = -Inf.
+*>
+*>          d) If 0.0 <= RELTOL then the input value of RELTOL
+*>                is used.
+*> \endverbatim
+*>
+*> \param[in] KP1
+*> \verbatim
+*>          KP1 is INTEGER
+*>          The index of the column with the maximum 2-norm in
+*>          the whole original matrix A_orig determined in the
+*>          main routine ZGEQP3RK. 1 <= KP1 <= N_orig.
+*> \endverbatim
+*>
+*> \param[in] MAXC2NRM
+*> \verbatim
+*>          MAXC2NRM is DOUBLE PRECISION
+*>          The maximum column 2-norm of the whole original
+*>          matrix A_orig computed in the main routine ZGEQP3RK.
+*>          MAXC2NRM >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*>          A is COMPLEX*16 array, dimension (LDA,N+NRHS)
+*>          On entry:
+*>              the M-by-N matrix A and M-by-NRHS matrix B, as in
+*>
+*>                                  N     NRHS
+*>              array_A   =   M  [ mat_A, mat_B ]
+*>
+*>          On exit:
+*>          1. The elements in block A(IOFFSET+1:M,1:KB) below
+*>             the diagonal together with the array TAU represent
+*>             the orthogonal matrix Q(KB) as a product of elementary
+*>             reflectors.
+*>          2. The upper triangular block of the matrix A stored
+*>             in A(IOFFSET+1:M,1:KB) is the triangular factor obtained.
+*>          3. The block of the matrix A stored in A(1:IOFFSET,1:N)
+*>             has been accordingly pivoted, but not factorized.
+*>          4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS).
+*>             The left part A(IOFFSET+1:M,KB+1:N) of this block
+*>             contains the residual of the matrix A, and,
+*>             if NRHS > 0, the right part of the block
+*>             A(IOFFSET+1:M,N+1:N+NRHS) contains the block of
+*>             the right-hand-side matrix B. Both these blocks have been
+*>             updated by multiplication from the left by Q(KB)**H.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*>          LDA is INTEGER
+*>          The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out]
+*> \verbatim
+*>          DONE is LOGICAL
+*>          TRUE: a) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to ABSTOL
+*>                   or RELTOL criterion,
+*>                b) if the factorization completed before processing
+*>                   all min(M-IOFFSET,NB,N) columns due to the
+*>                   residual matrix being a ZERO matrix.
+*>                c) when NaN was detected in the matrix A
+*>                   or in the array TAU.
+*>          FALSE: otherwise.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*>          KB is INTEGER
+*>          Factorization rank of the matrix A, i.e. the rank of
+*>          the factor R, which is the same as the number of non-zero
+*>          rows of the factor R.  0 <= KB <= min(M-IOFFSET,NB,N).
+*>
+*>          KB also represents the number of non-zero Householder
+*>          vectors.
+*> \endverbatim
+*>
+*> \param[out] MAXC2NRMK
+*> \verbatim
+*>          MAXC2NRMK is DOUBLE PRECISION
+*>          The maximum column 2-norm of the residual matrix,
+*>          when the factorization stopped at rank KB. MAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] RELMAXC2NRMK
+*> \verbatim
+*>          RELMAXC2NRMK is DOUBLE PRECISION
+*>          The ratio MAXC2NRMK / MAXC2NRM of the maximum column
+*>          2-norm of the residual matrix (when the factorization
+*>          stopped at rank KB) to the maximum column 2-norm of the
+*>          original matrix A_orig. RELMAXC2NRMK >= 0.
+*> \endverbatim
+*>
+*> \param[out] JPIV
+*> \verbatim
+*>          JPIV is INTEGER array, dimension (N)
+*>          Column pivot indices, for 1 <= j <= N, column j
+*>          of the matrix A was interchanged with column JPIV(j).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is COMPLEX*16 array, dimension (min(M-IOFFSET,N))
+*>          The scalar factors of the elementary reflectors.
+*> \endverbatim
+*>
+*> \param[in,out] VN1
+*> \verbatim
+*>          VN1 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the partial column norms.
+*> \endverbatim
+*>
+*> \param[in,out] VN2
+*> \verbatim
+*>          VN2 is DOUBLE PRECISION array, dimension (N)
+*>          The vector with the exact column norms.
+*> \endverbatim
+*>
+*> \param[out] AUXV
+*> \verbatim
+*>          AUXV is COMPLEX*16 array, dimension (NB)
+*>          Auxiliary vector.
+*> \endverbatim
+*>
+*> \param[out] F
+*> \verbatim
+*>          F is COMPLEX*16 array, dimension (LDF,NB)
+*>          Matrix F**H = L*(Y**H)*A.
+*> \endverbatim
+*>
+*> \param[in] LDF
+*> \verbatim
+*>          LDF is INTEGER
+*>          The leading dimension of the array F. LDF >= max(1,N+NRHS).
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*>          IWORK is INTEGER array, dimension (N-1).
+*>          Is a work array. ( IWORK is used to store indices
+*>          of "bad" columns for norm downdating in the residual
+*>          matrix ).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*>          INFO is INTEGER
+*>          1) INFO = 0: successful exit.
+*>          2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was
+*>             detected and the routine stops the computation.
+*>             The j_1-th column of the matrix A or the j_1-th
+*>             element of array TAU contains the first occurrence
+*>             of NaN in the factorization step KB+1 ( when KB columns
+*>             have been factorized ).
+*>
+*>             On exit:
+*>             KB                  is set to the number of
+*>                                    factorized columns without
+*>                                    exception.
+*>             MAXC2NRMK           is set to NaN.
+*>             RELMAXC2NRMK        is set to NaN.
+*>             TAU(KB+1:min(M,N))     is not set and contains undefined
+*>                                    elements. If j_1=KB+1, TAU(KB+1)
+*>                                    may contain NaN.
+*>          3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN
+*>             was detected, but +Inf (or -Inf) was detected and
+*>             the routine continues the computation until completion.
+*>             The (j_2-N)-th column of the matrix A contains the first
+*>             occurrence of +Inf (or -Inf) in the actorization
+*>             step KB+1 ( when KB columns have been factorized ).
+*> \endverbatim
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup laqp3rk
+*
+*> \par References:
+*  ================
+*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996.
+*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain.
+*> X. Sun, Computer Science Dept., Duke University, USA.
+*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
+*> A BLAS-3 version of the QR factorization with column pivoting.
+*> LAPACK Working Note 114
+*> \htmlonly
+*> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a>
+*> \endhtmlonly
+*> and in
+*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
+*> \htmlonly
+*> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a>
+*> \endhtmlonly
+*>
+*> [2] A partial column norm updating strategy developed in 2006.
+*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
+*> On the failure of rank revealing QR factorization software – a case study.
+*> LAPACK Working Note 176.
+*> \htmlonly
+*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a>
+*> \endhtmlonly
+*> and in
+*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
+*> \htmlonly
+*> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a>
+*> \endhtmlonly
+*
+*> \par Contributors:
+*  ==================
+*>
+*> \verbatim
+*>
+*>  November  2023, Igor Kozachenko, James Demmel,
+*>                  Computer Science Division,
+*>                  University of California, Berkeley
+*>
+*> \endverbatim
+*
+*  =====================================================================
+      SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL,
+     $                     RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB,
+     $                     MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU,
+     $                     VN1, VN2, AUXV, F, LDF, IWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      LOGICAL            DONE
+      INTEGER            INFO, IOFFSET, KB, KP1, LDA, LDF, M, N,
+     $                   NB, NRHS
+      DOUBLE PRECISION   ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK,
+     $                   RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * ), JPIV( * )
+      DOUBLE PRECISION   VN1( * ), VN2( * )
+      COMPLEX*16         A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. 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            ITEMP, J, K, MINMNFACT, MINMNUPDT,
+     $                   LSTICC, KP, I, IF
+      DOUBLE PRECISION   HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z
+      COMPLEX*16         AIK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMM, ZGEMV, ZLARFG, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      LOGICAL            DISNAN
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DZNRM2
+      EXTERNAL           DISNAN, DLAMCH, IDAMAX, DZNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize INFO
+*
+      INFO = 0
+*
+*     MINMNFACT in the smallest dimension of the submatrix
+*     A(IOFFSET+1:M,1:N) to be factorized.
+*
+      MINMNFACT = MIN( M-IOFFSET, N )
+      MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
+      NB = MIN( NB, MINMNFACT )
+      TOL3Z = SQRT( DLAMCH( 'Epsilon' ) )
+      HUGEVAL = DLAMCH( 'Overflow' )
+*
+*     Compute factorization in a while loop over NB columns,
+*     K is the column index in the block A(1:M,1:N).
+*
+      K = 0
+      LSTICC = 0
+      DONE = .FALSE.
+*
+      DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 )
+         K = K + 1
+         I = IOFFSET + K
+*
+         IF( I.EQ.1 ) THEN
+*
+*           We are at the first column of the original whole matrix A_orig,
+*           therefore we use the computed KP1 and MAXC2NRM from the
+*           main routine.
+*
+            KP = KP1
+*
+         ELSE
+*
+*           Determine the pivot column in K-th step, i.e. the index
+*           of the column with the maximum 2-norm in the
+*           submatrix A(I:M,K:N).
+*
+            KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
+*
+*           Determine the maximum column 2-norm and the relative maximum
+*           column 2-norm of the submatrix A(I:M,K:N) in step K.
+*
+            MAXC2NRMK = VN1( KP )
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains NaN, set
+*           INFO parameter to the column number, where the first NaN
+*           is found and return from the routine.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( DISNAN( MAXC2NRMK ) ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               INFO = KB + KP
+*
+*              Set RELMAXC2NRMK to NaN.
+*
+               RELMAXC2NRMK = MAXC2NRMK
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix contains NaN and we stop
+*              the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H.
+
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                  M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Array TAU(KF+1:MINMNFACT) is not set and contains
+*              undefined elements.
+*
+*              Return from the routine.
+*
+               RETURN
+            END IF
+*
+*           Quick return, if the submatrix A(I:M,K:N) is
+*           a zero matrix. We need to check it only if the column index
+*           (same as row index) is larger than 1, since the condition
+*           for the whole original matrix A_orig is checked in the main
+*           routine.
+*
+            IF( MAXC2NRMK.EQ.ZERO ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig.
+*
+               KB = K - 1
+               IF = I - 1
+               RELMAXC2NRMK = ZERO
+*
+*              There is no need to apply the block reflector to the
+*              residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*              since the submatrix is zero and we stop the computation.
+*              But, we need to apply the block reflector to the residual
+*              right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*              residual right hand sides exist.  This occurs
+*              when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*              A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                               A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H.
+*
+               IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                  M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA,
+     $                  F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = CZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           Check if the submatrix A(I:M,K:N) contains Inf,
+*           set INFO parameter to the column number, where
+*           the first Inf is found plus N, and continue
+*           the computation.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN
+               INFO = N + K - 1 + KP
+            END IF
+*
+*           ============================================================
+*
+*           Test for the second and third tolerance stopping criteria.
+*           NOTE: There is no need to test for ABSTOL.GE.ZERO, since
+*           MAXC2NRMK is non-negative. Similarly, there is no need
+*           to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is
+*           non-negative.
+*           We need to check the condition only if the
+*           column index (same as row index) of the original whole
+*           matrix is larger than 1, since the condition for whole
+*           original matrix is checked in the main routine.
+*
+            RELMAXC2NRMK =  MAXC2NRMK / MAXC2NRM
+*
+            IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN
+*
+               DONE = .TRUE.
+*
+*              Set KB, the number of factorized partial columns
+*                      that are non-zero in each step in the block,
+*                      i.e. the rank of the factor R.
+*              Set IF, the number of processed rows in the block, which
+*                      is the same as the number of processed rows in
+*                      the original whole matrix A_orig;
+*
+                  KB = K - 1
+                  IF = I - 1
+*
+*              Apply the block reflector to the residual of the
+*              matrix A and the residual of the right hand sides B, if
+*              the residual matrix and and/or the residual of the right
+*              hand sides exist,  i.e. if the submatrix
+*              A(I+1:M,KB+1:N+NRHS) exists.  This occurs when
+*                 KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*              A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                             A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H.
+*
+               IF( KB.LT.MINMNUPDT ) THEN
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                  M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA,
+     $                  F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA )
+               END IF
+*
+*              There is no need to recompute the 2-norm of the
+*              difficult columns, since we stop the factorization.
+*
+*              Set TAUs corresponding to the columns that were not
+*              factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO,
+*              which is equivalent to seting TAU(K:MINMNFACT) = CZERO.
+*
+               DO J = K, MINMNFACT
+                  TAU( J ) = CZERO
+               END DO
+*
+*              Return from the routine.
+*
+               RETURN
+*
+            END IF
+*
+*           ============================================================
+*
+*           End ELSE of IF(I.EQ.1)
+*
+         END IF
+*
+*        ===============================================================
+*
+*        If the pivot column is not the first column of the
+*        subblock A(1:M,K:N):
+*        1) swap the K-th column and the KP-th pivot column
+*           in A(1:M,1:N);
+*        2) swap the K-th row and the KP-th row in F(1:N,1:K-1)
+*        3) copy the K-th element into the KP-th element of the partial
+*           and exact 2-norm vectors VN1 and VN2. (Swap is not needed
+*           for VN1 and VN2 since we use the element with the index
+*           larger than K in the next loop step.)
+*        4) Save the pivot interchange with the indices relative to the
+*           the original matrix A_orig, not the block A(1:M,1:N).
+*
+         IF( KP.NE.K ) THEN
+            CALL ZSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 )
+            CALL ZSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF )
+            VN1( KP ) = VN1( K )
+            VN2( KP ) = VN2( K )
+            ITEMP = JPIV( KP )
+            JPIV( KP ) = JPIV( K )
+            JPIV( K ) = ITEMP
+         END IF
+*
+*        Apply previous Householder reflectors to column K:
+*        A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H.
+*
+         IF( K.GT.1 ) THEN
+            DO J = 1, K - 1
+               F( K, J ) = DCONJG( F( K, J ) )
+            END DO
+            CALL ZGEMV( 'No transpose', M-I+1, K-1, -CONE, A( I, 1 ),
+     $                  LDA, F( K, 1 ), LDF, CONE, A( I, K ), 1 )
+            DO J = 1, K - 1
+               F( K, J ) = DCONJG( F( K, J ) )
+            END DO
+         END IF
+*
+*        Generate elementary reflector H(k) using the column A(I:M,K).
+*
+         IF( I.LT.M ) THEN
+            CALL ZLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) )
+         ELSE
+            TAU( K ) = CZERO
+         END IF
+*
+*        Check if TAU(K) contains NaN, set INFO parameter
+*        to the column number where NaN is found and return from
+*        the routine.
+*        NOTE: There is no need to check TAU(K) for Inf,
+*        since ZLARFG cannot produce TAU(KK) or Householder vector
+*        below the diagonal containing Inf. Only BETA on the diagonal,
+*        returned by ZLARFG can contain Inf, which requires
+*        TAU(K) to contain NaN. Therefore, this case of generating Inf
+*        by ZLARFG is covered by checking TAU(K) for NaN.
+*
+         IF( DISNAN( DBLE( TAU(K) ) ) ) THEN
+            TAUNAN = DBLE( TAU(K) )
+         ELSE IF( DISNAN( DIMAG( TAU(K) ) ) ) THEN
+            TAUNAN = DIMAG( TAU(K) )
+         ELSE
+            TAUNAN = ZERO
+         END IF
+*
+         IF( DISNAN( TAUNAN ) ) THEN
+*
+            DONE = .TRUE.
+*
+*           Set KB, the number of factorized partial columns
+*                   that are non-zero in each step in the block,
+*                   i.e. the rank of the factor R.
+*           Set IF, the number of processed rows in the block, which
+*                   is the same as the number of processed rows in
+*                   the original whole matrix A_orig.
+*
+            KB = K - 1
+            IF = I - 1
+            INFO = K
+*
+*           Set MAXC2NRMK and  RELMAXC2NRMK to NaN.
+*
+            MAXC2NRMK = TAUNAN
+            RELMAXC2NRMK = TAUNAN
+*
+*           There is no need to apply the block reflector to the
+*           residual of the matrix A stored in A(KB+1:M,KB+1:N),
+*           since the submatrix contains NaN and we stop
+*           the computation.
+*           But, we need to apply the block reflector to the residual
+*           right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the
+*           residual right hand sides exist.  This occurs
+*           when ( NRHS != 0 AND KB <= (M-IOFFSET) ):
+*
+*           A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) -
+*                            A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H.
+*
+            IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN
+               CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $               M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA,
+     $               F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA )
+            END IF
+*
+*           There is no need to recompute the 2-norm of the
+*           difficult columns, since we stop the factorization.
+*
+*           Array TAU(KF+1:MINMNFACT) is not set and contains
+*           undefined elements.
+*
+*           Return from the routine.
+*
+            RETURN
+         END IF
+*
+*        ===============================================================
+*
+         AIK = A( I, K )
+         A( I, K ) = CONE
+*
+*        ===============================================================
+*
+*        Compute the current K-th column of F:
+*          1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K).
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL ZGEMV( 'Conjugate transpose', M-I+1, N+NRHS-K,
+     $                  TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1,
+     $                  CZERO, F( K+1, K ), 1 )
+         END IF
+*
+*           2) Zero out elements above and on the diagonal of the
+*              column K in matrix F, i.e elements F(1:K,K).
+*
+         DO J = 1, K
+            F( J, K ) = CZERO
+         END DO
+*
+*         3) Incremental updating of the K-th column of F:
+*        F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H
+*                    * A(I:M,K).
+*
+         IF( K.GT.1 ) THEN
+            CALL ZGEMV( 'Conjugate Transpose', M-I+1, K-1, -TAU( K ),
+     $                   A( I, 1 ), LDA, A( I, K ), 1, CZERO,
+     $                   AUXV( 1 ), 1 )
+*
+            CALL ZGEMV( 'No transpose', N+NRHS, K-1, CONE,
+     $                  F( 1, 1 ), LDF, AUXV( 1 ), 1, CONE,
+     $                  F( 1, K ), 1 )
+         END IF
+*
+*        ===============================================================
+*
+*        Update the current I-th row of A:
+*        A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS)
+*                         - A(I,1:K)*F(K+1:N+NRHS,1:K)**H.
+*
+         IF( K.LT.N+NRHS ) THEN
+            CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $            1, N+NRHS-K, K, -CONE, A( I, 1 ), LDA,
+     $            F( K+1, 1 ), LDF, CONE, A( I, K+1 ), LDA )
+         END IF
+*
+         A( I, K ) = AIK
+*
+*        Update the partial column 2-norms for the residual matrix,
+*        only if the residual matrix A(I+1:M,K+1:N) exists, i.e.
+*        when K < MINMNFACT = min( M-IOFFSET, N ).
+*
+         IF( K.LT.MINMNFACT ) THEN
+*
+            DO J = K + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ABS( A( I, J ) ) / VN1( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2.LE.TOL3Z ) THEN
+*
+*                    At J-index, we have a difficult column for the
+*                    update of the 2-norm. Save the index of the previous
+*                    difficult column in IWORK(J-1).
+*                    NOTE: ILSTCC > 1, threfore we can use IWORK only
+*                    with N-1 elements, where the elements are
+*                    shifted by 1 to the left.
+*
+                     IWORK( J-1 ) = LSTICC
+*
+*                    Set the index of the last difficult column LSTICC.
+*
+                     LSTICC = J
+*
+                  ELSE
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+                  END IF
+               END IF
+            END DO
+*
+         END IF
+*
+*        End of while loop.
+*
+      END DO
+*
+*     Now, afler the loop:
+*        Set KB, the number of factorized columns in the block;
+*        Set IF, the number of processed rows in the block, which
+*                is the same as the number of processed rows in
+*                the original whole matrix A_orig, IF = IOFFSET + KB.
+*
+      KB = K
+      IF = I
+*
+*     Apply the block reflector to the residual of the matrix A
+*     and the residual of the right hand sides B, if the residual
+*     matrix and and/or the residual of the right hand sides
+*     exist,  i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists.
+*     This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ):
+*
+*     A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) -
+*                         A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H.
+*
+      IF( KB.LT.MINMNUPDT ) THEN
+         CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $         M-IF, N+NRHS-KB, KB, -CONE, A( IF+1, 1 ), LDA,
+     $         F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA )
+      END IF
+*
+*     Recompute the 2-norm of the difficult columns.
+*     Loop over the index of the difficult columns from the largest
+*     to the smallest index.
+*
+      DO WHILE( LSTICC.GT.0 )
+*
+*        LSTICC is the index of the last difficult column is greater
+*        than 1.
+*        ITEMP is the index of the previous difficult column.
+*
+         ITEMP = IWORK( LSTICC-1 )
+*
+*        Compute the 2-norm explicilty for the last difficult column and
+*        save it in the partial and exact 2-norm vectors VN1 and VN2.
+*
+*        NOTE: The computation of VN1( LSTICC ) relies on the fact that
+*        DZNRM2 does not fail on vectors with norm below the value of
+*        SQRT(DLAMCH('S'))
+*
+         VN1( LSTICC ) = DZNRM2( M-IF, A( IF+1, LSTICC ), 1 )
+         VN2( LSTICC ) = VN1( LSTICC )
+*
+*        Downdate the index of the last difficult column to
+*        the index of the previous difficult column.
+*
+         LSTICC = ITEMP
+*
+      END DO
+*
+      RETURN
+*
+*     End of ZLAQP3RK
+*
+      END

lapack-netlib/TESTING/EIG/alareq.f

@@ -28,12 +28,12 @@
 *> to evaluate the input line which requested NMATS matrix types for
 *> PATH.  The flow of control is as follows:
 *>
-*> If NMATS = NTYPES then
+*> IF NMATS = NTYPES THEN
 *>    DOTYPE(1:NTYPES) = .TRUE.
-*> else
+*> ELSE
 *>    Read the next input line for NMATS matrix types
 *>    Set DOTYPE(I) = .TRUE. for each valid type I
-*> endif
+*> END IF
 *> \endverbatim
 *
 *  Arguments:

lapack-netlib/TESTING/EIG/alarqg.f

@@ -28,12 +28,12 @@
 *> to evaluate the input line which requested NMATS matrix types for
 *> PATH.  The flow of control is as follows:
 *>
-*> If NMATS = NTYPES then
+*> IF NMATS = NTYPES THEN
 *>    DOTYPE(1:NTYPES) = .TRUE.
-*> else
+*> ELSE
 *>    Read the next input line for NMATS matrix types
 *>    Set DOTYPE(I) = .TRUE. for each valid type I
-*> endif
+*> END IF
 *> \endverbatim
 *
 *  Arguments:

lapack-netlib/TESTING/LIN/CMakeLists.txt

@@ -9,7 +9,7 @@ set(DZLNTST dlaord.f)
 set(SLINTST schkaa.F
    schkeq.f schkgb.f schkge.f schkgt.f
    schklq.f schkpb.f schkpo.f schkps.f schkpp.f
-   schkpt.f schkq3.f schkql.f schkqr.f schkrq.f
+   schkpt.f schkq3.f schkqp3rk.f schkql.f schkqr.f schkrq.f
    schksp.f schksy.f schksy_rook.f schksy_rk.f 
    schksy_aa.f schksy_aa_2stage.f 
    schktb.f schktp.f schktr.f
@@ -56,7 +56,7 @@ set(CLINTST cchkaa.F
    cchkhe.f cchkhe_rook.f cchkhe_rk.f 
    cchkhe_aa.f cchkhe_aa_2stage.f
    cchkhp.f cchklq.f cchkpb.f
-   cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f
+   cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkql.f
    cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f
    cchksy_aa.f cchksy_aa_2stage.f
    cchktb.f
@@ -110,7 +110,7 @@ endif()
 set(DLINTST dchkaa.F
    dchkeq.f dchkgb.f dchkge.f dchkgt.f
    dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f
-   dchkpt.f dchkq3.f dchkql.f dchkqr.f dchkrq.f
+   dchkpt.f dchkq3.f dchkqp3rk.f dchkql.f dchkqr.f dchkrq.f
    dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f 
    dchksy_aa.f dchksy_aa_2stage.f
    dchktb.f dchktp.f dchktr.f
@@ -158,7 +158,7 @@ set(ZLINTST zchkaa.F
    zchkhe.f zchkhe_rook.f zchkhe_rk.f 
    zchkhe_aa.f zchkhe_aa_2stage.f
    zchkhp.f zchklq.f zchkpb.f
-   zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f
+   zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkql.f
    zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f
    zchksy_aa.f  zchksy_aa_2stage.f
    zchktb.f

lapack-netlib/TESTING/LIN/Makefile

@@ -45,7 +45,7 @@ DZLNTST = dlaord.o
 SLINTST = schkaa.o \
    schkeq.o schkgb.o schkge.o schkgt.o \
    schklq.o schkpb.o schkpo.o schkps.o schkpp.o \
-   schkpt.o schkq3.o schkql.o schkqr.o schkrq.o \
+   schkpt.o schkq3.o schkqp3rk.o schkql.o schkqr.o schkrq.o \
    schksp.o schksy.o schksy_rook.o schksy_rk.o  \
    schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \
    schktz.o \
@@ -89,7 +89,7 @@ CLINTST = cchkaa.o \
    cchkeq.o cchkgb.o cchkge.o cchkgt.o \
    cchkhe.o cchkhe_rook.o cchkhe_rk.o  \
    cchkhe_aa.o cchkhe_aa_2stage.o cchkhp.o cchklq.o cchkpb.o \
-   cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \
+   cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkqp3rk.o cchkql.o \
    cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o \
    cchksy_aa.o cchksy_aa_2stage.o cchktb.o \
    cchktp.o cchktr.o cchktz.o \
@@ -137,7 +137,7 @@ 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 dchkqr.o dchkrq.o \
+   dchkpt.o dchkq3.o dchkqp3rk.o dchkql.o dchkqr.o dchkrq.o \
    dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o  \
    dchksy_aa.o dchksy_aa_2stage.o dchktb.o dchktp.o dchktr.o \
    dchktz.o \
@@ -182,7 +182,7 @@ ZLINTST = zchkaa.o \
    zchkeq.o zchkgb.o zchkge.o zchkgt.o \
    zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhe_aa_2stage.o \
    zchkhp.o zchklq.o zchkpb.o \
-   zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \
+   zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkqp3rk.o zchkql.o \
    zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o \
    zchksy_aa.o zchksy_aa_2stage.o zchktb.o \
    zchktp.o zchktr.o zchktz.o \
@@ -269,35 +269,35 @@ proto-double: xlintstds xlintstrfd
 proto-complex: xlintstrfc
 proto-complex16: xlintstzc xlintstrfz
 
-xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
-xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB)
-	$(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^
+xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
+	$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
 
 $(ALINTST): $(FRC)
 $(SCLNTST): $(FRC)

lapack-netlib/TESTING/LIN/alaerh.f

@@ -797,6 +797,18 @@
             WRITE( NOUT, FMT = 9978 )
      $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT
          END IF
+*
+      ELSE IF( LSAMEN( 2, P2, 'QK' ) ) THEN
+*
+*        xQK:  truncated QR factorization with pivoting
+*
+         IF( LSAMEN( 7, SUBNAM( 2: 8 ), 'GEQP3RK' )  ) THEN
+            WRITE( NOUT, FMT = 9930 )
+     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT
+         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
+            WRITE( NOUT, FMT = 9978 )
+     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT
+         END IF
 *
       ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
 *
@@ -1147,6 +1159,11 @@
 *     What we do next
 *
  9949 FORMAT( ' ==> Doing only the condition estimate for this case' )
+*
+*     SUBNAM, INFO, M, N, NB, IMAT
+*
+ 9930 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> M =', I5,
+     $      ', N =', I5, ', NX =', I5, ', NB =', I4, ', type ', I2 )
 *
       RETURN
 *

lapack-netlib/TESTING/LIN/alahd.f

@@ -584,13 +584,27 @@
 *
 *        QR decomposition with column pivoting
 *
-         WRITE( IOUNIT, FMT = 9986 )PATH
+         WRITE( IOUNIT, FMT = 8006 )PATH
          WRITE( IOUNIT, FMT = 9969 )
          WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
          WRITE( IOUNIT, FMT = 9940 )1
          WRITE( IOUNIT, FMT = 9939 )2
          WRITE( IOUNIT, FMT = 9938 )3
          WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+      ELSE IF( LSAMEN( 2, P2, 'QK' ) ) THEN
+*
+*        truncated QR decomposition with column pivoting
+*
+         WRITE( IOUNIT, FMT = 8006 )PATH
+         WRITE( IOUNIT, FMT = 9871 )
+         WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+         WRITE( IOUNIT, FMT = 8060 )1
+         WRITE( IOUNIT, FMT = 8061 )2
+         WRITE( IOUNIT, FMT = 8062 )3
+         WRITE( IOUNIT, FMT = 8063 )4
+         WRITE( IOUNIT, FMT = 8064 )5
+         WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
 *
       ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN
 *
@@ -779,6 +793,8 @@
      $       'tall-skinny or short-wide matrices' )
  8005 FORMAT( / 1X, A3, ':  Householder reconstruction from TSQR',
      $       ' factorization output ', /,' for tall-skinny matrices.' )
+ 8006 FORMAT( / 1X, A3, ':  truncated QR factorization',
+     $        ' with column pivoting' )
 *
 *     GE matrix types
 *
@@ -922,6 +938,36 @@
      $      / 4X, '3. Geometric distribution', 10X,
      $      '6. Every second column fixed' )
 *
+*     QK matrix types
+*
+ 9871 FORMAT( 4X, ' 1. Zero matrix', /
+     $        4X, ' 2. Random, Diagonal, CNDNUM = 2', /
+     $        4X, ' 3. Random, Upper triangular, CNDNUM = 2', /
+     $        4X, ' 4. Random, Lower triangular, CNDNUM = 2', /
+     $        4X, ' 5. Random, First column is zero, CNDNUM = 2', /
+     $        4X, ' 6. Random, Last MINMN column is zero, CNDNUM = 2', /
+     $        4X, ' 7. Random, Last N column is zero, CNDNUM = 2', /
+     $        4X, ' 8. Random, Middle column in MINMN is zero,',
+     $               ' CNDNUM = 2', /
+     $        4X, ' 9. Random, First half of MINMN columns are zero,',
+     $                 ' CNDNUM = 2', /
+     $        4X, '10. Random, Last columns are zero starting from',
+     $                 ' MINMN/2+1, CNDNUM = 2', /
+     $        4X, '11. Random, Half MINMN columns in the middle are',
+     $                 ' zero starting from MINMN/2-(MINMN/2)/2+1,'
+     $                 ' CNDNUM = 2', /
+     $        4X, '12. Random, Odd columns are ZERO, CNDNUM = 2', /
+     $        4X, '13. Random, Even columns are ZERO, CNDNUM = 2', /
+     $        4X, '14. Random, CNDNUM = 2', /
+     $        4X, '15. Random, CNDNUM = sqrt(0.1/EPS)', /
+     $        4X, '16. Random, CNDNUM = 0.1/EPS', /
+     $        4X, '17. Random, CNDNUM = 0.1/EPS,',
+     $                 ' one small singular value S(N)=1/CNDNUM', /
+     $        4X, '18. Random, CNDNUM = 2, scaled near underflow,',
+     $                 ' NORM = SMALL = SAFMIN', /
+     $        4X, '19. Random, CNDNUM = 2, scaled near overflow,',
+     $            ' NORM = LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) )' )
+*
 *     TZ matrix types
 *
  9968 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X,
@@ -1030,9 +1076,8 @@
      $      ' * norm(C) * EPS )' )
  9940 FORMAT( 3X, I2, ': norm(svd(A) - svd(R)) / ',
      $      '( M * norm(svd(R)) * EPS )' )
- 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R )     / ( M * norm(A) * EPS )'
-     $       )
- 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q )      / ( M * EPS )' )
+ 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )')
+ 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' )
  9937 FORMAT( 3X, I2, ': norm( A - R*Q )       / ( M * norm(A) * EPS )'
      $       )
  9935 FORMAT( 3X, I2, ': norm( B - A * X )   / ',
@@ -1105,6 +1150,15 @@
  8054 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( M * norm(C) * EPS )' )
  8055 FORMAT(3X,I2,': norm( C*Q'' - C*Q'' ) / ( M * norm(C) * EPS )')
 
+ 8060 FORMAT( 3X, I2, ': 2-norm(svd(A) - svd(R)) / ',
+     $      '( max(M,N) * 2-norm(svd(R)) * EPS )' )
+ 8061 FORMAT( 3X, I2, ': 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A)',
+     $                ' * EPS )')
+ 8062 FORMAT( 3X, I2, ': 1-norm( I - Q''*Q ) / ( M * EPS )' )
+ 8063 FORMAT( 3X, I2, ': Returns 1.0D+100, if abs(R(K+1,K+1))',
+     $                 ' > abs(R(K,K)), where K=1:KFACT-1' )
+ 8064 FORMAT( 3X, I2, ': 1-norm(Q**T * B - Q**T * B ) / ( M * EPS )')
+
 *
       RETURN
 *

lapack-netlib/TESTING/LIN/alareq.f

@@ -28,12 +28,12 @@
 *> to evaluate the input line which requested NMATS matrix types for
 *> PATH.  The flow of control is as follows:
 *>
-*> If NMATS = NTYPES then
+*> IF NMATS = NTYPES THEN
 *>    DOTYPE(1:NTYPES) = .TRUE.
-*> else
+*> ELSE
 *>    Read the next input line for NMATS matrix types
 *>    Set DOTYPE(I) = .TRUE. for each valid type I
-*> endif
+*> END IF
 *> \endverbatim
 *
 *  Arguments:

lapack-netlib/TESTING/LIN/cchkaa.F

@@ -69,6 +69,7 @@
 *> CLQ    8               List types on next line if 0 < NTYPES <  8
 *> CQL    8               List types on next line if 0 < NTYPES <  8
 *> CQP    6               List types on next line if 0 < NTYPES <  6
+*> ZQK   19               List types on next line if 0 < NTYPES < 19
 *> CTZ    3               List types on next line if 0 < NTYPES <  3
 *> CLS    6               List types on next line if 0 < NTYPES <  6
 *> CEQ
@@ -153,12 +154,11 @@
      $                   NBVAL( MAXIN ), NBVAL2( MAXIN ),
      $                   NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
      $                   RANKVAL( MAXIN ), PIV( NMAX )
-      REAL               S( 2*NMAX )
-      COMPLEX            E( NMAX )
 *     ..
 *     .. Allocatable Arrays ..
       INTEGER AllocateStatus
-      REAL, DIMENSION(:), ALLOCATABLE :: RWORK
+      REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S
+      COMPLEX, DIMENSION(:), ALLOCATABLE :: E
       COMPLEX, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK
 *     ..
 *     .. External Functions ..
@@ -170,14 +170,14 @@
       EXTERNAL           ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE,
      $                   CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKHP,
      $                   CCHKLQ, CCHKUNHR_COL, CCHKPB, CCHKPO, CCHKPS,
-     $                   CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQR, CCHKRQ,
-     $                   CCHKSP, CCHKSY, CCHKSY_ROOK, CCHKSY_RK,
-     $                   CCHKSY_AA, CCHKTB,  CCHKTP, CCHKTR, CCHKTZ,
-     $                   CDRVGB, CDRVGE, CDRVGT, CDRVHE, CDRVHE_ROOK,
-     $                   CDRVHE_RK, CDRVHE_AA, CDRVHP, CDRVLS, CDRVPB,
-     $                   CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY,
-     $                   CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, ILAVER,
-     $                   CCHKQRT, CCHKQRTP
+     $                   CCHKPP, CCHKPT, CCHKQ3, CCHKQP3RK, CCHKQL,
+     $                   CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK,
+     $                   CCHKSY_RK, CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR,
+     $                   CCHKTZ, CDRVGB, CDRVGE, CDRVGT, CDRVHE,
+     $                   CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA, CDRVHP,
+     $                   CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP,
+     $                   CDRVSY, CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA,
+     $                   ILAVER, CCHKQRT, CCHKQRTP
 *     ..
 *     .. Scalars in Common ..
       LOGICAL            LERR, OK
@@ -203,6 +203,10 @@
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
       ALLOCATE ( WORK( NMAX, NMAX+MAXRHS+10 ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
+      ALLOCATE ( E( NMAX ), STAT = AllocateStatus )
+      IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
+      ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus)
+      IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
       ALLOCATE ( RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
 *     ..
@@ -1109,6 +1113,23 @@
          ELSE
             WRITE( NOUT, FMT = 9989 )PATH
          END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        QK: truncated QR factorization with pivoting
+*
+         NTYPES = 19
+         CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+         IF( TSTCHK ) THEN
+            CALL CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                   NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ),
+     $                   A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+     $                   S( 1 ), B( 1, 4 ),
+     $                   WORK, RWORK, IWORK, NOUT )
+         ELSE
+            WRITE( NOUT, FMT = 9989 )PATH
+         END IF
 *
       ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
 *

lapack-netlib/TESTING/LIN/cchkqp3rk.f

@@ -0,0 +1,836 @@
+*> \brief \b CCHKQP3RK
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+*     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+*     $                      B, COPYB, S, TAU,
+*     $                      WORK, RWORK, IWORK, NOUT )
+*      IMPLICIT NONE
+*
+*       .. Scalar Arguments ..
+*       INTEGER            NM, NN, NNB, NOUT
+*       REAL               THRESH
+*       ..
+*       .. Array Arguments ..
+*       LOGICAL            DOTYPE( * )
+*       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
+*      $                   NXVAL( * )
+*       REAL               S( * ), RWORK( * )
+*       COMPLEX            A( * ), COPYA( * ), TAU( * ), WORK( * )
+*       ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> CCHKQP3RK tests CGEQP3RK.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*>          DOTYPE is LOGICAL array, dimension (NTYPES)
+*>          The matrix types to be used for testing.  Matrices of type j
+*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*>          NM is INTEGER
+*>          The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*>          MVAL is INTEGER array, dimension (NM)
+*>          The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*>          NN is INTEGER
+*>          The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*>          NVAL is INTEGER array, dimension (NN)
+*>          The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] 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] NNB
+*> \verbatim
+*>          NNB is INTEGER
+*>          The number of values of NB and NX contained in the
+*>          vectors NBVAL and NXVAL.  The blocking parameters are used
+*>          in pairs (NB,NX).
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*>          NBVAL is INTEGER array, dimension (NNB)
+*>          The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NXVAL
+*> \verbatim
+*>          NXVAL is INTEGER array, dimension (NNB)
+*>          The values of the crossover point NX.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*>          THRESH is REAL
+*>          The threshold value for the test ratios.  A result is
+*>          included in the output file if RESULT >= THRESH.  To have
+*>          every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*>          A is COMPLEX array, dimension (MMAX*NMAX)
+*>          where MMAX is the maximum value of M in MVAL and NMAX is the
+*>          maximum value of N in NVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYA
+*> \verbatim
+*>          COPYA is COMPLEX array, dimension (MMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*>          B is COMPLEX array, dimension (MMAX*NSMAX)
+*>          where MMAX is the maximum value of M in MVAL and NSMAX is the
+*>          maximum value of NRHS in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYB
+*> \verbatim
+*>          COPYB is COMPLEX array, dimension (MMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] S
+*> \verbatim
+*>          S is REAL array, dimension
+*>                      (min(MMAX,NMAX))
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is COMPLEX array, dimension (MMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is COMPLEX array, dimension
+*>                      (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*>          RWORK is REAL array, dimension (4*NMAX)
+*> \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.
+*
+*> \ingroup complex_lin
+*
+*  =====================================================================
+      SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+     $                      B, COPYB, S, TAU,
+     $                      WORK, RWORK, IWORK, NOUT )
+      IMPLICIT NONE
+*
+*  -- LAPACK test routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            NM, NN, NNB, NNS, NOUT
+      REAL               THRESH
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            DOTYPE( * )
+      INTEGER            IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ),
+     $                   NSVAL( * ), NXVAL( * )
+      REAL               S( * ), RWORK( * )
+      COMPLEX            A( * ), COPYA( * ), B( * ), COPYB( * ),
+     $                   TAU( * ), WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NTYPES
+      PARAMETER          ( NTYPES = 19 )
+      INTEGER            NTESTS
+      PARAMETER          ( NTESTS = 5 )
+      REAL               ONE, ZERO, BIGNUM
+      COMPLEX            CONE, CZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0,
+     $                   CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ),
+     $                   BIGNUM = 1.0E+38 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          DIST, TYPE
+      CHARACTER*3        PATH
+      INTEGER            I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO,
+     $                   INB, IND_OFFSET_GEN,
+     $                   IND_IN, IND_OUT, INS, INFO,
+     $                   ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO,
+     $                   KFACT, KL, KMAX, KU, LDA, LW, LWORK,
+     $                   LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N,
+     $                   NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS,
+     $                   NRUN, NX, T
+      REAL               ANORM, CNDNUM, EPS, ABSTOL, RELTOL,
+     $                   DTEMP, MAXC2NRMK, RELMAXC2NRMK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 ), ISEEDY( 4 )
+      REAL               RESULT( NTESTS ), RDUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE
+      EXTERNAL           SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ALAERH, ALAHD, ALASUM, SLAORD, ICOPY, CAXPY,
+     $                   XLAENV, CGEQP3RK, CLACPY, CLASET, CLATB4,
+     $                   CLATMS, CUNMQR, CSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, MOD, REAL
+*     ..
+*     .. Scalars in Common ..
+      LOGICAL            LERR, OK
+      CHARACTER*32       SRNAMT
+      INTEGER            INFOT, IOUNIT, CUNMQR_LWORK
+*     ..
+*     .. Common blocks ..
+      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
+      COMMON             / SRNAMC / SRNAMT
+*     ..
+*     .. Data statements ..
+      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize constants and the random number seed.
+*
+      PATH( 1: 1 ) = 'Complex precision'
+      PATH( 2: 3 ) = 'QK'
+      NRUN = 0
+      NFAIL = 0
+      NERRS = 0
+      DO  I = 1, 4
+         ISEED( I ) = ISEEDY( I )
+      END DO
+      EPS = SLAMCH( 'Epsilon' )
+      INFOT = 0
+*
+      DO IM = 1, NM
+*
+*        Do for each value of M in MVAL.
+*
+         M = MVAL( IM )
+         LDA = MAX( 1, M )
+*
+         DO IN = 1, NN
+*
+*           Do for each value of N in NVAL.
+*
+            N = NVAL( IN )
+            MINMN = MIN( M, N )
+            LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ),
+     $                   M*N + 2*MINMN + 4*N )
+*
+            DO INS = 1, NNS
+               NRHS = NSVAL( INS )
+*
+*                 Set up parameters with CLATB4 and generate
+*                 M-by-NRHS B matrix with CLATMS.
+*                 IMAT = 14:
+*                 Random matrix, CNDNUM = 2, NORM = ONE,
+*                 MODE = 3 (geometric distribution of singular values).
+*
+                  CALL CLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'CLATMS'
+                  CALL CLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYB, LDA, WORK, INFO )
+*
+*                 Check error code from CLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M,
+     $                            NRHS, -1, -1, -1, 6, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+               DO IMAT = 1, NTYPES
+*
+*              Do the tests only if DOTYPE( IMAT ) is true.
+*
+               IF( .NOT.DOTYPE( IMAT ) )
+     $            CYCLE
+*
+*              The type of distribution used to generate the random
+*              eigen-/singular values:
+*              ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 )
+*
+*           Do for each type of NON-SYMMETRIC matrix:                               CNDNUM                     NORM                                     MODE
+*            1. Zero matrix
+*            2. Random, Diagonal, CNDNUM = 2                                        CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            3. Random, Upper triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            4. Random, Lower triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            5. Random, First column is zero, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            6. Random, Last MINMN column is zero, CNDNUM = 2                       CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            7. Random, Last N column is zero, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            8. Random, Middle column in MINMN is zero, CNDNUM = 2                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            9. Random, First half of MINMN columns are zero, CNDNUM = 2            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2   CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           11. Random, Half MINMN columns in the middle are zero starting
+*                  from  MINMN/2-(MINMN/2)/2+1, CNDNUM = 2                          CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           12. Random, Odd columns are ZERO, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           13. Random, Even columns are ZERO, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           14. Random, CNDNUM = 2                                                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           15. Random, CNDNUM = sqrt(0.1/EPS)                                      CNDNUM = BADC1 = sqrt(0.1/EPS)  ONE                                      3 ( geometric distribution of singular values )
+*           16. Random, CNDNUM = 0.1/EPS                                            CNDNUM = BADC2 = 0.1/EPS        ONE                                      3 ( geometric distribution of singular values )
+*           17. Random, CNDNUM = 0.1/EPS,                                           CNDNUM = BADC2 = 0.1/EPS        ONE                                      2 ( one small singular value, S(N)=1/CNDNUM )
+*                 one small singular value S(N)=1/CNDNUM
+*           18. Random, CNDNUM = 2, scaled near underflow                           CNDNUM = 2                      SMALL = SAFMIN
+*           19. Random, CNDNUM = 2, scaled near overflow                            CNDNUM = 2                      LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) )  3 ( geometric distribution of singular values )
+*
+               IF( IMAT.EQ.1 ) THEN
+*
+*                 Matrix 1: Zero matrix
+*
+                  CALL CLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA )
+                  DO I = 1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 )
+     $                  .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN
+*
+*                 Matrices 2-5.
+*
+*                 Set up parameters with DLATB4 and generate a test
+*                 matrix with CLATMS.
+*
+                  CALL CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'CLATMS'
+                  CALL CLATMS( M, N, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYA, LDA, WORK, INFO )
+*
+*                 Check error code from CLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, N,
+     $                            -1, -1, -1, IMAT, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+                  CALL SLAORD( 'Decreasing', MINMN, S, 1 )
+*
+               ELSE IF( MINMN.GE.2
+     $                  .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN
+*
+*                 Rectangular matrices 5-13 that contain zero columns,
+*                 only for matrices MINMN >=2.
+*
+*                 JB_ZERO is the column index of ZERO block.
+*                 NB_ZERO is the column block size of ZERO block.
+*                 NB_GEN is the column blcok size of the
+*                 generated block.
+*                 J_INC in the non_zero column index increment
+*                 for matrix 12 and 13.
+*                 J_FIRS_NZ is the index of the first non-zero
+*                 column.
+*
+                  IF( IMAT.EQ.5 ) THEN
+*
+*                    First column is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.6 ) THEN
+*
+*                    Last column MINMN is zero.
+*
+                     JB_ZERO = MINMN
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.7 ) THEN
+*
+*                    Last column N is zero.
+*
+                     JB_ZERO = N
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.8 ) THEN
+*
+*                    Middle column in MINMN is zero.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.9 ) THEN
+*
+*                    First half of MINMN columns is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.10 ) THEN
+*
+*                    Last columns are zero columns,
+*                    starting from (MINMN / 2 + 1) column.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = N - JB_ZERO + 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.11 ) THEN
+*
+*                    Half of the columns in the middle of MINMN
+*                    columns is zero, starting from
+*                    MINMN/2 - (MINMN/2)/2 + 1 column.
+*
+                     JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.12 ) THEN
+*
+*                    Odd-numbered columns are zero,
+*
+                     NB_GEN = N / 2
+                     NB_ZERO = N - NB_GEN
+                     J_INC = 2
+                     J_FIRST_NZ = 2
+*
+                  ELSE IF( IMAT.EQ.13 ) THEN
+*
+*                    Even-numbered columns are zero.
+*
+                     NB_ZERO = N / 2
+                     NB_GEN = N - NB_ZERO
+                     J_INC = 2
+                     J_FIRST_NZ = 1
+*
+                  END IF
+*
+*
+*                 1) Set the first NB_ZERO columns in COPYA(1:M,1:N)
+*                    to zero.
+*
+                  CALL CLASET( 'Full', M, NB_ZERO, CZERO, CZERO,
+     $                         COPYA, LDA )
+*
+*                    2) Generate an M-by-(N-NB_ZERO) matrix with the
+*                       chosen singular value distribution
+*                       in COPYA(1:M,NB_ZERO+1:N).
+*
+                  CALL CLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU,
+     $                         ANORM, MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'CLATMS'
+*
+                  IND_OFFSET_GEN = NB_ZERO * LDA
+*
+                  CALL CLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE,
+     $                        CNDNUM, ANORM, KL, KU, 'No packing',
+     $                        COPYA( IND_OFFSET_GEN + 1 ), LDA,
+     $                        WORK, INFO )
+*
+*                 Check error code from CLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M,
+     $                            NB_GEN, -1, -1, -1, IMAT, NFAIL,
+     $                            NERRS, NOUT )
+                     CYCLE
+                  END IF
+*
+*                 3) Swap the gererated colums from the right side
+*                 NB_GEN-size block in COPYA into correct column
+*                 positions.
+*
+                  IF( IMAT.EQ.6
+     $                    .OR. IMAT.EQ.7
+     $                    .OR. IMAT.EQ.8
+     $                    .OR. IMAT.EQ.10
+     $                    .OR. IMAT.EQ.11 ) THEN
+*
+*                    Move by swapping the generated columns
+*                    from the right NB_GEN-size block from
+*                    (NB_ZERO+1:NB_ZERO+JB_ZERO)
+*                    into columns (1:JB_ZERO-1).
+*
+                     DO J = 1, JB_ZERO-1, 1
+                        CALL CSWAP( M,
+     $                        COPYA( ( NB_ZERO+J-1)*LDA+1), 1,
+     $                        COPYA( (J-1)*LDA + 1 ), 1 )
+                     END DO
+*
+                  ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN
+*
+*                    ( IMAT = 12, Odd-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the even zero colums in the
+*                    left NB_ZERO-size block.
+*
+*                    ( IMAT = 13, Even-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the odd zero colums in the
+*                    left NB_ZERO-size block.
+*
+                     DO J = 1, NB_GEN, 1
+                        IND_OUT = ( NB_ZERO+J-1 )*LDA + 1
+                        IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA
+     $                            + 1
+                        CALL CSWAP( M,
+     $                              COPYA( IND_OUT ), 1,
+     $                              COPYA( IND_IN), 1 )
+                        END DO
+*
+                  END IF
+*
+*                 5) Order the singular values generated by
+*                    DLAMTS in decreasing order and add trailing zeros
+*                    that correspond to zero columns.
+*                    The total number of singular values is MINMN.
+*
+                  MINMNB_GEN = MIN( M, NB_GEN )
+*
+                  CALL SLAORD( 'Decreasing', MINMNB_GEN, S, 1 )
+
+                  DO I = MINMNB_GEN+1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE
+*
+*                    IF(MINMN.LT.2) skip this size for this matrix type.
+*
+                     CYCLE
+               END IF
+*
+*              Initialize a copy array for a pivot array for DGEQP3RK.
+*
+               DO I = 1, N
+                  IWORK( I ) = 0
+               END DO
+*
+               DO INB = 1, NNB
+*
+*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
+*
+                  NB = NBVAL( INB )
+                  CALL XLAENV( 1, NB )
+                  NX = NXVAL( INB )
+                  CALL XLAENV( 3, NX )
+*
+*                 We do MIN(M,N)+1 because we need a test for KMAX > N,
+*                 when KMAX is larger than MIN(M,N), KMAX should be
+*                 KMAX = MIN(M,N)
+*
+                  DO KMAX = 0, MIN(M,N)+1
+*
+*                 Get a working copy of COPYA into A( 1:M,1:N ).
+*                 Get a working copy of COPYB into A( 1:M, (N+1):NRHS ).
+*                 Get a working copy of COPYB into into B( 1:M, 1:NRHS ).
+*                 Get a working copy of IWORK(1:N) awith zeroes into
+*                 which is going to be used as pivot array IWORK( N+1:2N ).
+*                 NOTE: IWORK(2N+1:3N) is going to be used as a WORK array
+*                 for the routine.
+*
+                  CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA )
+                  CALL CLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         A( LDA*N + 1 ),  LDA )
+                  CALL CLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         B,  LDA )
+                  CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
+*
+                  ABSTOL = -1.0
+                  RELTOl = -1.0
+*
+*                 Compute the QR factorization with pivoting of A
+*
+                  LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ),
+     $                              3*N + NRHS - 1 ) )
+*
+*                 Compute CGEQP3RK factorization of A.
+*
+                  SRNAMT = 'CGEQP3RK'
+                  CALL CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                           A, LDA, KFACT, MAXC2NRMK,
+     $                           RELMAXC2NRMK, IWORK( N+1 ), TAU,
+     $                           WORK, LW, RWORK, IWORK( 2*N+1 ),
+     $                           INFO )
+*
+*                 Check error code from CGEQP3RK.
+*
+                  IF( INFO.LT.0 )
+     $               CALL ALAERH( PATH, 'CGEQP3RK', INFO, 0, ' ',
+     $                            M, N, NX, -1, NB, IMAT,
+     $                            NFAIL, NERRS, NOUT )
+*
+                  IF( KFACT.EQ.MINMN ) THEN
+*
+*                 Compute test 1:
+*
+*                 This test in only for the full rank factorization of
+*                 the matrix A.
+*
+*                 Array S(1:min(M,N)) contains svd(A) the sigular values
+*                 of the original matrix A in decreasing absolute value
+*                 order. The test computes svd(R), the vector sigular
+*                 values of the upper trapezoid of A(1:M,1:N) that
+*                 contains the factor R, in decreasing order. The test
+*                 returns the ratio:
+*
+*                 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
+*
+                     RESULT( 1 ) = CQRT12( M, N, A, LDA, S, WORK,
+     $                                     LWORK , RWORK )
+*
+                     DO T = 1, 1
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL, NB, NX,
+     $                        IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                   End test 1
+*
+                  END IF
+
+*                 Compute test 2:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
+*
+                  RESULT( 2 ) = CQPT01( M, N, KFACT, COPYA, A, LDA, TAU,
+     $                          IWORK( N+1 ), WORK, LWORK )
+*
+*                 Compute test 3:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( Q**T * Q - I ) / ( M * EPS )
+*
+                  RESULT( 3 ) = CQRT11( M, KFACT, A, LDA, TAU, WORK,
+     $                          LWORK )
+*
+*                 Print information about the tests that did not pass
+*                 the threshold.
+*
+                  DO T = 2, 3
+                     IF( RESULT( T ).GE.THRESH ) THEN
+                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                     CALL ALAHD( NOUT, PATH )
+                        WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
+     $                      NRHS, KMAX, ABSTOL, RELTOL,
+     $                      NB, NX, IMAT, T, RESULT( T )
+                        NFAIL = NFAIL + 1
+                     END IF
+                  END DO
+                  NRUN = NRUN + 2
+*
+*                 Compute test 4:
+*
+*                 This test is only for the factorizations with the
+*                 rank greater than 2.
+*                 The elements on the diagonal of R should be non-
+*                 increasing.
+*
+*                 The test returns the ratio:
+*
+*                 Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
+*                 K=1:KFACT-1
+*
+                  IF( MIN(KFACT, MINMN).GE.2 ) THEN
+*
+                     DO J = 1, KFACT-1, 1
+*
+                        DTEMP = (( ABS( A( (J-1)*M+J ) ) -
+     $                          ABS( A( (J)*M+J+1 ) ) ) /
+     $                          ABS( A(1) ) )
+*
+                        IF( DTEMP.LT.ZERO ) THEN
+                           RESULT( 4 ) = BIGNUM
+                        END IF
+*
+                     END DO
+*
+*                    Print information about the tests that did not
+*                    pass the threshold.
+*
+                     DO T = 4, 4
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK',
+     $                        M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T,
+     $                        RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End test 4.
+*
+                  END IF
+*
+*                 Compute test 5:
+*
+*                 This test in only for matrix A with min(M,N) > 0.
+*
+*                 The test returns the ratio:
+*
+*                 1-norm(Q**T * B - Q**T * B ) /
+*                       ( M * EPS )
+*
+*                 (1) Compute B:=Q**T * B in the matrix B.
+*
+                  IF( MINMN.GT.0 ) THEN
+*
+                     LWORK_MQR = MAX(1, NRHS)
+                     CALL CUNMQR( 'Left', 'Conjugate transpose',
+     $                         M, NRHS, KFACT, A, LDA, TAU, B, LDA,
+     $                         WORK, LWORK_MQR, INFO )
+*
+                     DO I = 1, NRHS
+*
+*                       Compare N+J-th column of A and J-column of B.
+*
+                        CALL CAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1,
+     $                                    B( ( I-1 )*LDA+1 ), 1 )
+                     END DO
+*
+                     RESULT( 5 ) =
+     $               ABS(
+     $               CLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) /
+     $               ( REAL( M )*SLAMCH( 'Epsilon' ) )
+     $               )
+*
+*                    Print information about the tests that did not pass
+*                    the threshold.
+*
+                     DO T = 5, 5
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End compute test 5.
+*
+                  END IF
+*
+*                 END DO KMAX = 1, MIN(M,N)+1
+*
+                  END DO
+*
+*                 END DO for INB = 1, NNB
+*
+               END DO
+*
+*              END DO  for IMAT = 1, NTYPES
+*
+               END DO
+*
+*              END DO for INS = 1, NNS
+*
+            END DO
+*
+*           END DO for IN = 1, NN
+*
+         END DO
+*
+*        END DO for IM = 1, NM
+*
+      END DO
+*
+*     Print a summary of the results.
+*
+      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5,
+     $        ', KMAX =', I5, ', ABSTOL =', G12.5,
+     $        ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4,
+     $        ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
+*
+*     End of CCHKQP3RK
+*
+      END

lapack-netlib/TESTING/LIN/clatb4.f

@@ -154,9 +154,6 @@
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, SQRT
 *     ..
-*     .. External Subroutines ..
-      EXTERNAL           SLABAD
-*     ..
 *     .. Save statement ..
       SAVE               EPS, SMALL, LARGE, BADC1, BADC2, FIRST
 *     ..
@@ -174,11 +171,6 @@
          BADC1 = SQRT( BADC2 )
          SMALL = SLAMCH( 'Safe minimum' )
          LARGE = ONE / SMALL
-*
-*        If it looks like we're on a Cray, take the square root of
-*        SMALL and LARGE to avoid overflow and underflow problems.
-*
-         CALL SLABAD( SMALL, LARGE )
          SMALL = SHRINK*( SMALL / EPS )
          LARGE = ONE / SMALL
       END IF
@@ -233,6 +225,110 @@
          ELSE
             ANORM = ONE
          END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        xQK: truncated QR with pivoting.
+*             Set parameters to generate a general
+*             M x N matrix.
+*
+*        Set TYPE, the type of matrix to be generated.  'N' is nonsymmetric.
+*
+         TYPE = 'N'
+*
+*        Set DIST, the type of distribution for the random
+*        number generator. 'S' is
+*
+         DIST = 'S'
+*
+*        Set the lower and upper bandwidths.
+*
+         IF( IMAT.EQ.2 ) THEN
+*
+*           2. Random, Diagonal, CNDNUM = 2
+*
+            KL = 0
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.3 ) THEN
+*
+*           3. Random, Upper triangular,  CNDNUM = 2
+*
+            KL = 0
+            KU = MAX( N-1, 0 )
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.4 ) THEN
+*
+*          4. Random, Lower triangular,  CNDNUM = 2
+*
+            KL = MAX( M-1, 0 )
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE
+*
+*           5.-19. Rectangular matrix
+*
+            KL = MAX( M-1, 0 )
+            KU = MAX( N-1, 0 )
+*
+            IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN
+*
+*              5.-14. Random, CNDNUM = 2.
+*
+               CNDNUM = TWO
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.15 ) THEN
+*
+*              15. Random, CNDNUM = sqrt(0.1/EPS)
+*
+               CNDNUM = BADC1
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.16 ) THEN
+*
+*              16. Random, CNDNUM = 0.1/EPS
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.17 ) THEN
+*
+*              17. Random, CNDNUM = 0.1/EPS,
+*                  one small singular value S(N)=1/CNDNUM
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 2
+*
+            ELSE IF( IMAT.EQ.18 ) THEN
+*
+*              18. Random, scaled near underflow
+*
+               CNDNUM = TWO
+               ANORM = SMALL
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.19 ) THEN
+*
+*              19. Random, scaled near overflow
+*
+               CNDNUM = TWO
+               ANORM = LARGE
+               MODE = 3
+*
+            END IF
+*
+         END IF
 *
       ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
 *
@@ -517,17 +613,18 @@
 *
 *        Set the norm and condition number.
 *
-         IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN
+         MAT = ABS( IMAT )
+         IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN
             CNDNUM = BADC1
-         ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN
+         ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN
             CNDNUM = BADC2
          ELSE
             CNDNUM = TWO
          END IF
 *
-         IF( IMAT.EQ.4 ) THEN
+         IF( MAT.EQ.4 ) THEN
             ANORM = SMALL
-         ELSE IF( IMAT.EQ.5 ) THEN
+         ELSE IF( MAT.EQ.5 ) THEN
             ANORM = LARGE
          ELSE
             ANORM = ONE

lapack-netlib/TESTING/LIN/cqpt01.f

@@ -33,7 +33,8 @@
 *> Householder vectors, and the rest of AF contains a partially updated
 *> matrix.
 *>
-*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
+*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) )
+*> where || . || is matrix one norm.
 *> \endverbatim
 *
 *  Arguments:
@@ -172,28 +173,28 @@
 *
       NORMA = CLANGE( 'One-norm', M, N, A, LDA, RWORK )
 *
-      DO 30 J = 1, K
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, K
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = AF( I, J )
-   10    CONTINUE
-         DO 20 I = J + 1, M
+         END DO
+         DO I = J + 1, M
             WORK( ( J-1 )*M+I ) = ZERO
-   20    CONTINUE
-   30 CONTINUE
-      DO 40 J = K + 1, N
+         END DO
+      END DO
+      DO J = K + 1, N
          CALL CCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 )
-   40 CONTINUE
+      END DO
 *
       CALL CUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK,
      $             M, WORK( M*N+1 ), LWORK-M*N, INFO )
 *
-      DO 50 J = 1, N
+      DO J = 1, N
 *
 *        Compare i-th column of QR and jpvt(i)-th column of A
 *
          CALL CAXPY( M, CMPLX( -ONE ), A( 1, JPVT( J ) ), 1,
      $               WORK( ( J-1 )*M+1 ), 1 )
-   50 CONTINUE
+      END DO
 *
       CQPT01 = CLANGE( 'One-norm', M, N, WORK, M, RWORK ) /
      $         ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/cqrt11.f

@@ -157,9 +157,9 @@
       CALL CUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU,
      $             WORK, M, WORK( M*M+1 ), INFO )
 *
-      DO 10 J = 1, M
+      DO J = 1, M
          WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE
-   10 CONTINUE
+      END DO
 *
       CQRT11 = CLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) /
      $         ( REAL( M )*SLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/cqrt12.f

@@ -28,7 +28,7 @@
 *> CQRT12 computes the singular values `svlues' of the upper trapezoid
 *> of A(1:M,1:N) and returns the ratio
 *>
-*>      || s - svlues||/(||svlues||*eps*max(M,N))
+*>      || svlues -s ||/( ||s||*eps*max(M,N) )
 *> \endverbatim
 *
 *  Arguments:
@@ -125,8 +125,8 @@
       EXTERNAL           CLANGE, SASUM, SLAMCH, SNRM2
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CGEBD2, CLASCL, CLASET, SAXPY, SBDSQR, SLABAD,
-     $                   SLASCL, XERBLA
+      EXTERNAL           CGEBD2, CLASCL, CLASET, SAXPY, SBDSQR, SLASCL,
+     $                   XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CMPLX, MAX, MIN, REAL
@@ -153,17 +153,16 @@
 *     Copy upper triangle of A into work
 *
       CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M )
-      DO 20 J = 1, N
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, N
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = A( I, J )
-   10    CONTINUE
-   20 CONTINUE
+         END DO
+      END DO
 *
 *     Get machine parameters
 *
       SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
       BIGNUM = ONE / SMLNUM
-      CALL SLABAD( SMLNUM, BIGNUM )
 *
 *     Scale work if max entry outside range [SMLNUM,BIGNUM]
 *
@@ -207,9 +206,9 @@
 *
       ELSE
 *
-         DO 30 I = 1, MN
+         DO I = 1, MN
             RWORK( I ) = ZERO
-   30    CONTINUE
+         END DO
       END IF
 *
 *     Compare s and singular values of work

lapack-netlib/TESTING/LIN/dchkaa.F

@@ -63,6 +63,7 @@
 *> DLQ    8               List types on next line if 0 < NTYPES <  8
 *> DQL    8               List types on next line if 0 < NTYPES <  8
 *> DQP    6               List types on next line if 0 < NTYPES <  6
+*> DQK    19              List types on next line if 0 < NTYPES <  19
 *> DTZ    3               List types on next line if 0 < NTYPES <  3
 *> DLS    6               List types on next line if 0 < NTYPES <  6
 *> DEQ
@@ -149,12 +150,12 @@
      $                   NBVAL( MAXIN ), NBVAL2( MAXIN ),
      $                   NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
      $                   RANKVAL( MAXIN ), PIV( NMAX )
-      DOUBLE PRECISION   E( NMAX ), S( 2*NMAX )
 *     ..
 *     .. Allocatable Arrays ..
       INTEGER AllocateStatus
-      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK
-      DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK      
+      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK, S
+      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: E
+      DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK
 *     ..
 *     .. External Functions ..
       LOGICAL            LSAME, LSAMEN
@@ -164,13 +165,13 @@
 *     .. External Subroutines ..
       EXTERNAL           ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ,
      $                   DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP,
-     $                   DCHKPT, DCHKQ3, DCHKQL, DCHKQR, DCHKRQ, DCHKSP,
-     $                   DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA,
-     $                   DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE,
-     $                   DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT,
-     $                   DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK,
-     $                   DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, DCHKQRTP,
-     $                   DCHKLQT,DCHKTSQR
+     $                   DCHKPT, DCHKQ3, DCHKQP3RK, DCHKQL, DCHKQR,
+     $                   DCHKRQ, DCHKSP, DCHKSY, DCHKSY_ROOK, DCHKSY_RK,
+     $                   DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR, DCHKTZ,
+     $                   DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO,
+     $                   DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK,
+     $                   DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT,
+     $                   DCHKQRTP, DCHKLQT,DCHKTSQR
 *     ..
 *     .. Scalars in Common ..
       LOGICAL            LERR, OK
@@ -197,6 +198,10 @@
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
       ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
+      ALLOCATE ( E( NMAX ), STAT = AllocateStatus )
+      IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
+      ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus )
+      IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
       ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
 *
@@ -919,9 +924,26 @@
          CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
 *
          IF( TSTCHK ) THEN
-            CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
-     $                   THRESH, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
-     $                   B( 1, 3 ), WORK, IWORK, NOUT )
+            CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL,
+     $                   NXVAL, THRESH, A( 1, 1 ), A( 1, 2 ),
+     $                   B( 1, 1 ), B( 1, 3 ), WORK, IWORK, NOUT )
+         ELSE
+            WRITE( NOUT, FMT = 9989 )PATH
+         END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        QK: truncated QR factorization with pivoting
+*
+         NTYPES = 19
+         CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+         IF( TSTCHK ) THEN
+            CALL DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                      NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ),
+     $                      A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+     $                      B( 1, 3 ), B( 1, 4 ),
+     $                      WORK, IWORK, NOUT )
          ELSE
             WRITE( NOUT, FMT = 9989 )PATH
          END IF

lapack-netlib/TESTING/LIN/dchkq3.f

@@ -30,7 +30,7 @@
 *>
 *> \verbatim
 *>
-*> DCHKQ3 tests DGEQP3.
+*> DCHKQ3 tests  DGEQP3.
 *> \endverbatim
 *
 *  Arguments:

lapack-netlib/TESTING/LIN/dchkqp3rk.f

@@ -0,0 +1,832 @@
+*> \brief \b DCHKQP3RK
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+*     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+*     $                      B, COPYB, S, TAU,
+*     $                      WORK, IWORK, NOUT )
+*      IMPLICIT NONE
+*
+*  -- LAPACK test routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+*      INTEGER            NM, NN, NNS, NNB, NOUT
+*      DOUBLE PRECISION   THRESH
+*     ..
+*     .. Array Arguments ..
+*      LOGICAL            DOTYPE( * )
+*      INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
+*     $                   NVAL( * ), NXVAL( * )
+*      DOUBLE PRECISION   A( * ), COPYA( * ), B( * ), COPYB( * ),
+*     $                   S( * ), TAU( * ), WORK( * )
+*     ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> DCHKQP3RK tests DGEQP3RK.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*>          DOTYPE is LOGICAL array, dimension (NTYPES)
+*>          The matrix types to be used for testing.  Matrices of type j
+*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*>          NM is INTEGER
+*>          The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*>          MVAL is INTEGER array, dimension (NM)
+*>          The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*>          NN is INTEGER
+*>          The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*>          NVAL is INTEGER array, dimension (NN)
+*>          The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] 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] NNB
+*> \verbatim
+*>          NNB is INTEGER
+*>          The number of values of NB and NX contained in the
+*>          vectors NBVAL and NXVAL.  The blocking parameters are used
+*>          in pairs (NB,NX).
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*>          NBVAL is INTEGER array, dimension (NNB)
+*>          The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NXVAL
+*> \verbatim
+*>          NXVAL is INTEGER array, dimension (NNB)
+*>          The values of the crossover point NX.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*>          THRESH is DOUBLE PRECISION
+*>          The threshold value for the test ratios.  A result is
+*>          included in the output file if RESULT >= THRESH.  To have
+*>          every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*>          A is DOUBLE PRECISION array, dimension (MMAX*NMAX)
+*>          where MMAX is the maximum value of M in MVAL and NMAX is the
+*>          maximum value of N in NVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYA
+*> \verbatim
+*>          COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*>          B is DOUBLE PRECISION array, dimension (MMAX*NSMAX)
+*>          where MMAX is the maximum value of M in MVAL and NSMAX is the
+*>          maximum value of NRHS in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYB
+*> \verbatim
+*>          COPYB is DOUBLE PRECISION array, dimension (MMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] S
+*> \verbatim
+*>          S is DOUBLE PRECISION array, dimension
+*>                      (min(MMAX,NMAX))
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is DOUBLE PRECISION array, dimension (MMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is DOUBLE PRECISION array, dimension
+*>                      (MMAX*NMAX + 4*NMAX + MMAX)
+*> \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.
+*
+*> \ingroup double_lin
+*
+*  =====================================================================
+      SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+     $                      B, COPYB, S, TAU,
+     $                      WORK, IWORK, NOUT )
+      IMPLICIT NONE
+*
+*  -- LAPACK test routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            NM, NN, NNB, NNS, NOUT
+      DOUBLE PRECISION   THRESH
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            DOTYPE( * )
+      INTEGER            IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ),
+     $                   NSVAL( * ), NXVAL( * )
+      DOUBLE PRECISION   A( * ), COPYA( * ), B( * ), COPYB( * ),
+     $                   S( * ), TAU( * ), WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NTYPES
+      PARAMETER          ( NTYPES = 19 )
+      INTEGER            NTESTS
+      PARAMETER          ( NTESTS = 5 )
+      DOUBLE PRECISION   ONE, ZERO, BIGNUM
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0,
+     $                     BIGNUM = 1.0D+38 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          DIST, TYPE
+      CHARACTER*3        PATH
+      INTEGER            I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO,
+     $                   INB, IND_OFFSET_GEN,
+     $                   IND_IN, IND_OUT, INS, INFO,
+     $                   ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO,
+     $                   KFACT, KL, KMAX, KU, LDA, LW, LWORK,
+     $                   LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N,
+     $                   NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS,
+     $                   NRUN, NX, T
+      DOUBLE PRECISION   ANORM, CNDNUM, EPS, ABSTOL, RELTOL,
+     $                   DTEMP, MAXC2NRMK, RELMAXC2NRMK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 ), ISEEDY( 4 )
+      DOUBLE PRECISION   RESULT( NTESTS ), RDUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE,
+     $                   DLAPY2
+      EXTERNAL           DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ALAERH, ALAHD, ALASUM, DAXPY, DGEQP3RK,
+     $                   DLACPY, DLAORD, DLASET, DLATB4, DLATMS,
+     $                   DORMQR, DSWAP, ICOPY, XLAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, MOD
+*     ..
+*     .. Scalars in Common ..
+      LOGICAL            LERR, OK
+      CHARACTER*32       SRNAMT
+      INTEGER            INFOT, IOUNIT
+*     ..
+*     .. Common blocks ..
+      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
+      COMMON             / SRNAMC / SRNAMT
+*     ..
+*     .. Data statements ..
+      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize constants and the random number seed.
+*
+      PATH( 1: 1 ) = 'Double precision'
+      PATH( 2: 3 ) = 'QK'
+      NRUN = 0
+      NFAIL = 0
+      NERRS = 0
+      DO I = 1, 4
+         ISEED( I ) = ISEEDY( I )
+      END DO
+      EPS = DLAMCH( 'Epsilon' )
+      INFOT = 0
+*
+      DO IM = 1, NM
+*
+*        Do for each value of M in MVAL.
+*
+         M = MVAL( IM )
+         LDA = MAX( 1, M )
+*
+         DO IN = 1, NN
+*
+*           Do for each value of N in NVAL.
+*
+            N = NVAL( IN )
+            MINMN = MIN( M, N )
+            LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ),
+     $                   M*N + 2*MINMN + 4*N )
+*
+            DO INS = 1, NNS
+               NRHS = NSVAL( INS )
+*
+*                 Set up parameters with DLATB4 and generate
+*                 M-by-NRHS B matrix with DLATMS.
+*                 IMAT = 14:
+*                 Random matrix, CNDNUM = 2, NORM = ONE,
+*                 MODE = 3 (geometric distribution of singular values).
+*
+                  CALL DLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'DLATMS'
+                  CALL DLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYB, LDA, WORK, INFO )
+
+
+*
+*                 Check error code from DLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M,
+     $                            NRHS, -1, -1, -1, 6, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+               DO IMAT = 1, NTYPES
+*
+*              Do the tests only if DOTYPE( IMAT ) is true.
+*
+               IF( .NOT.DOTYPE( IMAT ) )
+     $            CYCLE
+*
+*              The type of distribution used to generate the random
+*              eigen-/singular values:
+*              ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 )
+*
+*           Do for each type of NON-SYMMETRIC matrix:                               CNDNUM                     NORM                                     MODE
+*            1. Zero matrix
+*            2. Random, Diagonal, CNDNUM = 2                                        CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            3. Random, Upper triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            4. Random, Lower triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            5. Random, First column is zero, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            6. Random, Last MINMN column is zero, CNDNUM = 2                       CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            7. Random, Last N column is zero, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            8. Random, Middle column in MINMN is zero, CNDNUM = 2                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            9. Random, First half of MINMN columns are zero, CNDNUM = 2            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2   CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           11. Random, Half MINMN columns in the middle are zero starting
+*                  from  MINMN/2-(MINMN/2)/2+1, CNDNUM = 2                          CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           12. Random, Odd columns are ZERO, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           13. Random, Even columns are ZERO, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           14. Random, CNDNUM = 2                                                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           15. Random, CNDNUM = sqrt(0.1/EPS)                                      CNDNUM = BADC1 = sqrt(0.1/EPS)  ONE                                      3 ( geometric distribution of singular values )
+*           16. Random, CNDNUM = 0.1/EPS                                            CNDNUM = BADC2 = 0.1/EPS        ONE                                      3 ( geometric distribution of singular values )
+*           17. Random, CNDNUM = 0.1/EPS,                                           CNDNUM = BADC2 = 0.1/EPS        ONE                                      2 ( one small singular value, S(N)=1/CNDNUM )
+*                 one small singular value S(N)=1/CNDNUM
+*           18. Random, CNDNUM = 2, scaled near underflow                           CNDNUM = 2                      SMALL = SAFMIN
+*           19. Random, CNDNUM = 2, scaled near overflow                            CNDNUM = 2                      LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) )  3 ( geometric distribution of singular values )
+*
+               IF( IMAT.EQ.1 ) THEN
+*
+*                 Matrix 1: Zero matrix
+*
+                  CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
+                  DO I = 1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 )
+     $                  .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN
+*
+*                 Matrices 2-5.
+*
+*                 Set up parameters with DLATB4 and generate a test
+*                 matrix with DLATMS.
+*
+                  CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'DLATMS'
+                  CALL DLATMS( M, N, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYA, LDA, WORK, INFO )
+*
+*                 Check error code from DLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N,
+     $                            -1, -1, -1, IMAT, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+                  CALL DLAORD( 'Decreasing', MINMN, S, 1 )
+*
+               ELSE IF( MINMN.GE.2
+     $                  .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN
+*
+*                 Rectangular matrices 5-13 that contain zero columns,
+*                 only for matrices MINMN >=2.
+*
+*                 JB_ZERO is the column index of ZERO block.
+*                 NB_ZERO is the column block size of ZERO block.
+*                 NB_GEN is the column blcok size of the
+*                 generated block.
+*                 J_INC in the non_zero column index increment
+*                 for matrix 12 and 13.
+*                 J_FIRS_NZ is the index of the first non-zero
+*                 column.
+*
+                  IF( IMAT.EQ.5 ) THEN
+*
+*                    First column is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.6 ) THEN
+*
+*                    Last column MINMN is zero.
+*
+                     JB_ZERO = MINMN
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.7 ) THEN
+*
+*                    Last column N is zero.
+*
+                     JB_ZERO = N
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.8 ) THEN
+*
+*                    Middle column in MINMN is zero.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.9 ) THEN
+*
+*                    First half of MINMN columns is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.10 ) THEN
+*
+*                    Last columns are zero columns,
+*                    starting from (MINMN / 2 + 1) column.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = N - JB_ZERO + 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.11 ) THEN
+*
+*                    Half of the columns in the middle of MINMN
+*                    columns is zero, starting from
+*                    MINMN/2 - (MINMN/2)/2 + 1 column.
+*
+                     JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.12 ) THEN
+*
+*                    Odd-numbered columns are zero,
+*
+                     NB_GEN = N / 2
+                     NB_ZERO = N - NB_GEN
+                     J_INC = 2
+                     J_FIRST_NZ = 2
+*
+                  ELSE IF( IMAT.EQ.13 ) THEN
+*
+*                    Even-numbered columns are zero.
+*
+                     NB_ZERO = N / 2
+                     NB_GEN = N - NB_ZERO
+                     J_INC = 2
+                     J_FIRST_NZ = 1
+*
+                  END IF
+*
+*
+*                 1) Set the first NB_ZERO columns in COPYA(1:M,1:N)
+*                    to zero.
+*
+                  CALL DLASET( 'Full', M, NB_ZERO, ZERO, ZERO,
+     $                         COPYA, LDA )
+*
+*                    2) Generate an M-by-(N-NB_ZERO) matrix with the
+*                       chosen singular value distribution
+*                       in COPYA(1:M,NB_ZERO+1:N).
+*
+                  CALL DLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU,
+     $                         ANORM, MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'DLATMS'
+*
+                  IND_OFFSET_GEN = NB_ZERO * LDA
+*
+                  CALL DLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE,
+     $                        CNDNUM, ANORM, KL, KU, 'No packing',
+     $                        COPYA( IND_OFFSET_GEN + 1 ), LDA,
+     $                        WORK, INFO )
+*
+*                 Check error code from DLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M,
+     $                            NB_GEN, -1, -1, -1, IMAT, NFAIL,
+     $                            NERRS, NOUT )
+                     CYCLE
+                  END IF
+*
+*                 3) Swap the gererated colums from the right side
+*                 NB_GEN-size block in COPYA into correct column
+*                 positions.
+*
+                  IF( IMAT.EQ.6
+     $                    .OR. IMAT.EQ.7
+     $                    .OR. IMAT.EQ.8
+     $                    .OR. IMAT.EQ.10
+     $                    .OR. IMAT.EQ.11 ) THEN
+*
+*                    Move by swapping the generated columns
+*                    from the right NB_GEN-size block from
+*                    (NB_ZERO+1:NB_ZERO+JB_ZERO)
+*                    into columns (1:JB_ZERO-1).
+*
+                     DO J = 1, JB_ZERO-1, 1
+                        CALL DSWAP( M,
+     $                        COPYA( ( NB_ZERO+J-1)*LDA+1), 1,
+     $                        COPYA( (J-1)*LDA + 1 ), 1 )
+                     END DO
+*
+                  ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN
+*
+*                    ( IMAT = 12, Odd-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the even zero colums in the
+*                    left NB_ZERO-size block.
+*
+*                    ( IMAT = 13, Even-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the odd zero colums in the
+*                    left NB_ZERO-size block.
+*
+                     DO J = 1, NB_GEN, 1
+                        IND_OUT = ( NB_ZERO+J-1 )*LDA + 1
+                        IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA
+     $                            + 1
+                        CALL DSWAP( M,
+     $                              COPYA( IND_OUT ), 1,
+     $                              COPYA( IND_IN), 1 )
+                        END DO
+*
+                  END IF
+*
+*                 5) Order the singular values generated by
+*                    DLAMTS in decreasing order and add trailing zeros
+*                    that correspond to zero columns.
+*                    The total number of singular values is MINMN.
+*
+                  MINMNB_GEN = MIN( M, NB_GEN )
+*
+                  DO I = MINMNB_GEN+1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE
+*
+*                    IF(MINMN.LT.2) skip this size for this matrix type.
+*
+                     CYCLE
+               END IF
+*
+*              Initialize a copy array for a pivot array for DGEQP3RK.
+*
+               DO I = 1, N
+                  IWORK( I ) = 0
+               END DO
+*
+               DO INB = 1, NNB
+*
+*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
+*
+                  NB = NBVAL( INB )
+                  CALL XLAENV( 1, NB )
+                  NX = NXVAL( INB )
+                  CALL XLAENV( 3, NX )
+*
+*                 We do MIN(M,N)+1 because we need a test for KMAX > N,
+*                 when KMAX is larger than MIN(M,N), KMAX should be
+*                 KMAX = MIN(M,N)
+*
+                  DO KMAX = 0, MIN(M,N)+1
+*
+*                 Get a working copy of COPYA into A( 1:M,1:N ).
+*                 Get a working copy of COPYB into A( 1:M, (N+1):NRHS ).
+*                 Get a working copy of COPYB into into B( 1:M, 1:NRHS ).
+*                 Get a working copy of IWORK(1:N) awith zeroes into
+*                 which is going to be used as pivot array IWORK( N+1:2N ).
+*                 NOTE: IWORK(2N+1:3N) is going to be used as a WORK array
+*                 for the routine.
+*
+                  CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
+                  CALL DLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         A( LDA*N + 1 ),  LDA )
+                  CALL DLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         B,  LDA )
+                  CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
+*
+                  ABSTOL = -1.0
+                  RELTOL = -1.0
+*
+*                 Compute the QR factorization with pivoting of A
+*
+                  LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ),
+     $                              3*N + NRHS - 1 ) )
+*
+*                 Compute DGEQP3RK factorization of A.
+*
+                  SRNAMT = 'DGEQP3RK'
+                  CALL DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                           A, LDA, KFACT, MAXC2NRMK,
+     $                           RELMAXC2NRMK, IWORK( N+1 ), TAU,
+     $                           WORK, LW, IWORK( 2*N+1 ), INFO )
+*
+*                 Check error code from DGEQP3RK.
+*
+                  IF( INFO.LT.0 )
+     $               CALL ALAERH( PATH, 'DGEQP3RK', INFO, 0, ' ',
+     $                            M, N, NX, -1, NB, IMAT,
+     $                            NFAIL, NERRS, NOUT )
+*
+*                 Compute test 1:
+*
+*                 This test in only for the full rank factorization of
+*                 the matrix A.
+*
+*                 Array S(1:min(M,N)) contains svd(A) the sigular values
+*                 of the original matrix A in decreasing absolute value
+*                 order. The test computes svd(R), the vector sigular
+*                 values of the upper trapezoid of A(1:M,1:N) that
+*                 contains the factor R, in decreasing order. The test
+*                 returns the ratio:
+*
+*                 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
+*
+                  IF( KFACT.EQ.MINMN ) THEN
+*
+                     RESULT( 1 ) = DQRT12( M, N, A, LDA, S, WORK,
+     $                                     LWORK )
+*
+                     DO T = 1, 1
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL, NB, NX,
+     $                        IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                   End test 1
+*
+                  END IF
+*
+*                 Compute test 2:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
+*
+                  RESULT( 2 ) = DQPT01( M, N, KFACT, COPYA, A, LDA, TAU,
+     $                          IWORK( N+1 ), WORK, LWORK )
+*
+*                 Compute test 3:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( Q**T * Q - I ) / ( M * EPS )
+*
+                  RESULT( 3 ) = DQRT11( M, KFACT, A, LDA, TAU, WORK,
+     $                          LWORK )
+*
+*                 Print information about the tests that did not pass
+*                 the threshold.
+*
+                  DO T = 2, 3
+                     IF( RESULT( T ).GE.THRESH ) THEN
+                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                     CALL ALAHD( NOUT, PATH )
+                        WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N,
+     $                      NRHS, KMAX, ABSTOL, RELTOL,
+     $                      NB, NX, IMAT, T, RESULT( T )
+                        NFAIL = NFAIL + 1
+                     END IF
+                  END DO
+                  NRUN = NRUN + 2
+*
+*                 Compute test 4:
+*
+*                 This test is only for the factorizations with the
+*                 rank greater than 2.
+*                 The elements on the diagonal of R should be non-
+*                 increasing.
+*
+*                 The test returns the ratio:
+*
+*                 Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
+*                 K=1:KFACT-1
+*
+                  IF( MIN(KFACT, MINMN).GE.2 ) THEN
+*
+                     DO J = 1, KFACT-1, 1
+
+                        DTEMP = (( ABS( A( (J-1)*M+J ) ) -
+     $                          ABS( A( (J)*M+J+1 ) ) ) /
+     $                          ABS( A(1) ) )
+*
+                        IF( DTEMP.LT.ZERO ) THEN
+                           RESULT( 4 ) = BIGNUM
+                        END IF
+*
+                     END DO
+*
+*                    Print information about the tests that did not
+*                    pass the threshold.
+*
+                     DO T = 4, 4
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK',
+     $                        M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T,
+     $                        RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End test 4.
+*
+                  END IF
+*
+*                 Compute test 5:
+*
+*                 This test in only for matrix A with min(M,N) > 0.
+*
+*                 The test returns the ratio:
+*
+*                 1-norm(Q**T * B - Q**T * B ) /
+*                       ( M * EPS )
+*
+*                 (1) Compute B:=Q**T * B in the matrix B.
+*
+                  IF( MINMN.GT.0 ) THEN
+*
+                     LWORK_MQR = MAX(1, NRHS)
+                     CALL DORMQR( 'Left', 'Transpose',
+     $                         M, NRHS, KFACT, A, LDA, TAU, B, LDA,
+     $                         WORK, LWORK_MQR, INFO )
+*
+                     DO I = 1, NRHS
+*
+*                       Compare N+J-th column of A and J-column of B.
+*
+                        CALL DAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1,
+     $                                 B( ( I-1 )*LDA+1 ), 1 )
+                     END DO
+*
+                   RESULT( 5 ) =
+     $               ABS(
+     $               DLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) /
+     $               ( DBLE( M )*DLAMCH( 'Epsilon' ) )
+     $               )
+*
+*                    Print information about the tests that did not pass
+*                    the threshold.
+*
+                     DO T = 5, 5
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End compute test 5.
+*
+                  END IF
+*
+*                 END DO KMAX = 1, MIN(M,N)+1
+*
+                  END DO
+*
+*                 END DO for INB = 1, NNB
+*
+               END DO
+*
+*              END DO  for IMAT = 1, NTYPES
+*
+               END DO
+*
+*              END DO for INS = 1, NNS
+*
+            END DO
+*
+*           END DO for IN = 1, NN
+*
+         END DO
+*
+*        END DO for IM = 1, NM
+*
+      END DO
+*
+*     Print a summary of the results.
+*
+      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5,
+     $        ', KMAX =', I5, ', ABSTOL =', G12.5,
+     $        ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4,
+     $        ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
+*
+*     End of DCHKQP3RK
+*
+      END

lapack-netlib/TESTING/LIN/dlatb4.f

@@ -133,7 +133,7 @@
 *
 *     .. Parameters ..
       DOUBLE PRECISION   SHRINK, TENTH
-      PARAMETER          ( SHRINK = 0.25D0, TENTH = 0.1D+0 )
+      PARAMETER          ( SHRINK = 0.25D+0, TENTH = 0.1D+0 )
       DOUBLE PRECISION   ONE
       PARAMETER          ( ONE = 1.0D+0 )
       DOUBLE PRECISION   TWO
@@ -153,9 +153,6 @@
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, SQRT
 *     ..
-*     .. External Subroutines ..
-      EXTERNAL           DLABAD
-*     ..
 *     .. Save statement ..
       SAVE               EPS, SMALL, LARGE, BADC1, BADC2, FIRST
 *     ..
@@ -173,11 +170,6 @@
          BADC1 = SQRT( BADC2 )
          SMALL = DLAMCH( 'Safe minimum' )
          LARGE = ONE / SMALL
-*
-*        If it looks like we're on a Cray, take the square root of
-*        SMALL and LARGE to avoid overflow and underflow problems.
-*
-         CALL DLABAD( SMALL, LARGE )
          SMALL = SHRINK*( SMALL / EPS )
          LARGE = ONE / SMALL
       END IF
@@ -232,6 +224,110 @@
          ELSE
             ANORM = ONE
          END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        xQK: truncated QR with pivoting.
+*             Set parameters to generate a general
+*             M x N matrix.
+*
+*        Set TYPE, the type of matrix to be generated.  'N' is nonsymmetric.
+*
+         TYPE = 'N'
+*
+*        Set DIST, the type of distribution for the random
+*        number generator. 'S' is
+*
+         DIST = 'S'
+*
+*        Set the lower and upper bandwidths.
+*
+         IF( IMAT.EQ.2 ) THEN
+*
+*           2. Random, Diagonal, CNDNUM = 2
+*
+            KL = 0
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.3 ) THEN
+*
+*           3. Random, Upper triangular,  CNDNUM = 2
+*
+            KL = 0
+            KU = MAX( N-1, 0 )
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.4 ) THEN
+*
+*          4. Random, Lower triangular,  CNDNUM = 2
+*
+            KL = MAX( M-1, 0 )
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE
+*
+*           5.-19. Rectangular matrix
+*
+            KL = MAX( M-1, 0 )
+            KU = MAX( N-1, 0 )
+*
+            IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN
+*
+*              5.-14. Random, CNDNUM = 2.
+*
+               CNDNUM = TWO
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.15 ) THEN
+*
+*              15. Random, CNDNUM = sqrt(0.1/EPS)
+*
+               CNDNUM = BADC1
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.16 ) THEN
+*
+*              16. Random, CNDNUM = 0.1/EPS
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.17 ) THEN
+*
+*              17. Random, CNDNUM = 0.1/EPS,
+*                  one small singular value S(N)=1/CNDNUM
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 2
+*
+            ELSE IF( IMAT.EQ.18 ) THEN
+*
+*              18. Random, scaled near underflow
+*
+               CNDNUM = TWO
+               ANORM = SMALL
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.19 ) THEN
+*
+*              19. Random, scaled near overflow
+*
+               CNDNUM = TWO
+               ANORM = LARGE
+               MODE = 3
+*
+            END IF
+*
+         END IF
 *
       ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
 *
@@ -518,17 +614,18 @@
 *
 *        Set the norm and condition number.
 *
-         IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN
+         MAT = ABS( IMAT )
+         IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN
             CNDNUM = BADC1
-         ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN
+         ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN
             CNDNUM = BADC2
          ELSE
             CNDNUM = TWO
          END IF
 *
-         IF( IMAT.EQ.4 ) THEN
+         IF( MAT.EQ.4 ) THEN
             ANORM = SMALL
-         ELSE IF( IMAT.EQ.5 ) THEN
+         ELSE IF( MAT.EQ.5 ) THEN
             ANORM = LARGE
          ELSE
             ANORM = ONE

lapack-netlib/TESTING/LIN/dqpt01.f

@@ -28,12 +28,13 @@
 *>
 *> DQPT01 tests the QR-factorization with pivoting of a matrix A.  The
 *> array AF contains the (possibly partial) QR-factorization of A, where
-*> the upper triangle of AF(1:k,1:k) is a partial triangular factor,
-*> the entries below the diagonal in the first k columns are the
+*> the upper triangle of AF(1:K,1:K) is a partial triangular factor,
+*> the entries below the diagonal in the first K columns are the
 *> Householder vectors, and the rest of AF contains a partially updated
 *> matrix.
 *>
-*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
+*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ),
+*> where || . || is matrix one norm.
 *> \endverbatim
 *
 *  Arguments:
@@ -172,28 +173,41 @@
 *
       NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK )
 *
-      DO 30 J = 1, K
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, K
+*
+*        Copy the upper triangular part of the factor R stored
+*        in AF(1:K,1:K) into the work array WORK.
+*
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = AF( I, J )
-   10    CONTINUE
-         DO 20 I = J + 1, M
+         END DO
+*
+*        Zero out the elements below the diagonal in the work array.
+*
+         DO I = J + 1, M
             WORK( ( J-1 )*M+I ) = ZERO
-   20    CONTINUE
-   30 CONTINUE
-      DO 40 J = K + 1, N
+         END DO
+      END DO
+*
+*     Copy columns (K+1,N) from AF into the work array WORK.
+*     AF(1:K,K+1:N) contains the rectangular block of the upper trapezoidal
+*     factor R, AF(K+1:M,K+1:N) contains the partially updated residual
+*     matrix of R.
+*
+      DO J = K + 1, N
          CALL DCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 )
-   40 CONTINUE
+      END DO
 *
       CALL DORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK,
      $             M, WORK( M*N+1 ), LWORK-M*N, INFO )
 *
-      DO 50 J = 1, N
+      DO J = 1, N
 *
-*        Compare i-th column of QR and jpvt(i)-th column of A
+*        Compare J-th column of QR and JPVT(J)-th column of A.
 *
          CALL DAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ),
      $               1 )
-   50 CONTINUE
+      END DO
 *
       DQPT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK ) /
      $         ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/dqrt11.f

@@ -157,9 +157,9 @@
       CALL DORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M,
      $             WORK( M*M+1 ), INFO )
 *
-      DO 10 J = 1, M
+      DO J = 1, M
          WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE
-   10 CONTINUE
+      END DO
 *
       DQRT11 = DLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) /
      $         ( DBLE( M )*DLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/dqrt12.f

@@ -26,7 +26,7 @@
 *> DQRT12 computes the singular values `svlues' of the upper trapezoid
 *> of A(1:M,1:N) and returns the ratio
 *>
-*>      || s - svlues||/(||svlues||*eps*max(M,N))
+*>      || svlues - s ||/(||s||*eps*max(M,N))
 *> \endverbatim
 *
 *  Arguments:
@@ -113,8 +113,7 @@
       EXTERNAL           DASUM, DLAMCH, DLANGE, DNRM2
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           DAXPY, DBDSQR, DGEBD2, DLABAD, DLASCL, DLASET,
-     $                   XERBLA
+      EXTERNAL           DAXPY, DBDSQR, DGEBD2, DLASCL, DLASET, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          DBLE, MAX, MIN
@@ -145,17 +144,16 @@
 *     Copy upper triangle of A into work
 *
       CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
-      DO 20 J = 1, N
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, N
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = A( I, J )
-   10    CONTINUE
-   20 CONTINUE
+         END DO
+      END DO
 *
 *     Get machine parameters
 *
       SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
       BIGNUM = ONE / SMLNUM
-      CALL DLABAD( SMLNUM, BIGNUM )
 *
 *     Scale work if max entry outside range [SMLNUM,BIGNUM]
 *
@@ -199,16 +197,18 @@
 *
       ELSE
 *
-         DO 30 I = 1, MN
+         DO I = 1, MN
             WORK( M*N+I ) = ZERO
-   30    CONTINUE
+         END DO
       END IF
 *
 *     Compare s and singular values of work
 *
       CALL DAXPY( MN, -ONE, S, 1, WORK( M*N+1 ), 1 )
+*
       DQRT12 = DASUM( MN, WORK( M*N+1 ), 1 ) /
-     $         ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
+     $  ( DLAMCH('Epsilon') * DBLE( MAX( M, N ) ) )
+*
       IF( NRMSVL.NE.ZERO )
      $   DQRT12 = DQRT12 / NRMSVL
 *

lapack-netlib/TESTING/LIN/schkaa.F

@@ -63,6 +63,7 @@
 *> SLQ    8               List types on next line if 0 < NTYPES <  8
 *> SQL    8               List types on next line if 0 < NTYPES <  8
 *> SQP    6               List types on next line if 0 < NTYPES <  6
+*> DQK    19              List types on next line if 0 < NTYPES <  19
 *> STZ    3               List types on next line if 0 < NTYPES <  3
 *> SLS    6               List types on next line if 0 < NTYPES <  6
 *> SEQ
@@ -147,11 +148,11 @@
      $                   NBVAL( MAXIN ), NBVAL2( MAXIN ),
      $                   NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
      $                   RANKVAL( MAXIN ), PIV( NMAX )
-      REAL               E( NMAX ), S( 2*NMAX )
 *     ..
 *     .. Allocatable Arrays ..
       INTEGER AllocateStatus
-      REAL, DIMENSION(:), ALLOCATABLE :: RWORK
+      REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S
+      REAL, DIMENSION(:), ALLOCATABLE :: E
       REAL, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK
 *     ..
 *     .. External Functions ..
@@ -162,13 +163,13 @@
 *     .. External Subroutines ..
       EXTERNAL           ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ,
      $                   SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP,
-     $                   SCHKPT, SCHKQ3, SCHKQL, SCHKQR, SCHKRQ, SCHKSP,
-     $                   SCHKSY, SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA,
-     $                   SCHKTB, SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE,
-     $                   SDRVGT, SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT,
-     $                   SDRVSP, SDRVSY, SDRVSY_ROOK, SDRVSY_RK,
-     $                   SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP,
-     $                   SCHKLQT, SCHKTSQR
+     $                   SCHKPT, SCHKQ3, SCHKQP3RK, SCHKQL, SCHKQR,
+     $                   SCHKRQ, SCHKSP, SCHKSY, SCHKSY_ROOK, SCHKSY_RK,
+     $                   SCHKSY_AA, SCHKTB, SCHKTP, SCHKTR, SCHKTZ,
+     $                   SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO,
+     $                   SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK,
+     $                   SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT,
+     $                   SCHKQRTP, SCHKLQT, SCHKTSQR
 *     ..
 *     .. Scalars in Common ..
       LOGICAL            LERR, OK
@@ -188,13 +189,17 @@
 *     ..
 *     .. Allocate memory dynamically ..
 *
-      ALLOCATE (A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus )
+      ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
-      ALLOCATE (B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus )
+      ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
-      ALLOCATE (WORK( NMAX, NMAX+MAXRHS+30 ) , STAT = AllocateStatus )
+      ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
-      ALLOCATE (RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus )
+      ALLOCATE ( E( NMAX ), STAT = AllocateStatus )
+      IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
+      ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus )
+      IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
+      ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" 
 *     ..
 *     .. Executable Statements ..
@@ -920,6 +925,23 @@
          ELSE
             WRITE( NOUT, FMT = 9989 )PATH
          END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        QK: truncated QR factorization with pivoting
+*
+         NTYPES = 19
+         CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+         IF( TSTCHK ) THEN
+            CALL SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                      NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ),
+     $                      A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+     $                      B( 1, 3 ), B( 1, 4 ),
+     $                      WORK, IWORK, NOUT )
+         ELSE
+            WRITE( NOUT, FMT = 9989 )PATH
+         END IF
 *
       ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
 *

lapack-netlib/TESTING/LIN/schkqp3rk.f

@@ -0,0 +1,831 @@
+*> \brief \b SCHKQP3RK
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+*     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+*     $                      B, COPYB, S, TAU,
+*     $                      WORK, IWORK, NOUT )
+*      IMPLICIT NONE
+*
+*  -- LAPACK test routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+*      INTEGER            NM, NN, NNS, NNB, NOUT
+*      REAL               THRESH
+*     ..
+*     .. Array Arguments ..
+*      LOGICAL            DOTYPE( * )
+*      INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
+*     $                   NVAL( * ), NXVAL( * )
+*      REAL               A( * ), COPYA( * ), B( * ), COPYB( * ),
+*     $                   S( * ), TAU( * ), WORK( * )
+*     ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> SCHKQP3RK tests SGEQP3RK.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*>          DOTYPE is LOGICAL array, dimension (NTYPES)
+*>          The matrix types to be used for testing.  Matrices of type j
+*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*>          NM is INTEGER
+*>          The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*>          MVAL is INTEGER array, dimension (NM)
+*>          The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*>          NN is INTEGER
+*>          The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*>          NVAL is INTEGER array, dimension (NN)
+*>          The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] 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] NNB
+*> \verbatim
+*>          NNB is INTEGER
+*>          The number of values of NB and NX contained in the
+*>          vectors NBVAL and NXVAL.  The blocking parameters are used
+*>          in pairs (NB,NX).
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*>          NBVAL is INTEGER array, dimension (NNB)
+*>          The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NXVAL
+*> \verbatim
+*>          NXVAL is INTEGER array, dimension (NNB)
+*>          The values of the crossover point NX.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*>          THRESH is REAL
+*>          The threshold value for the test ratios.  A result is
+*>          included in the output file if RESULT >= THRESH.  To have
+*>          every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*>          A is REAL array, dimension (MMAX*NMAX)
+*>          where MMAX is the maximum value of M in MVAL and NMAX is the
+*>          maximum value of N in NVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYA
+*> \verbatim
+*>          COPYA is REAL array, dimension (MMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*>          B is REAL array, dimension (MMAX*NSMAX)
+*>          where MMAX is the maximum value of M in MVAL and NSMAX is the
+*>          maximum value of NRHS in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYB
+*> \verbatim
+*>          COPYB is REAL array, dimension (MMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] S
+*> \verbatim
+*>          S is REAL array, dimension
+*>                      (min(MMAX,NMAX))
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is REAL array, dimension (MMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is REAL array, dimension
+*>                      (MMAX*NMAX + 4*NMAX + MMAX)
+*> \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.
+*
+*> \ingroup single_lin
+*
+*  =====================================================================
+      SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+     $                      B, COPYB, S, TAU,
+     $                      WORK, IWORK, NOUT )
+      IMPLICIT NONE
+*
+*  -- LAPACK test routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            NM, NN, NNB, NNS, NOUT
+      REAL               THRESH
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            DOTYPE( * )
+      INTEGER            IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ),
+     $                   NSVAL( * ), NXVAL( * )
+      REAL               A( * ), COPYA( * ), B( * ), COPYB( * ),
+     $                   S( * ), TAU( * ), WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NTYPES
+      PARAMETER          ( NTYPES = 19 )
+      INTEGER            NTESTS
+      PARAMETER          ( NTESTS = 5 )
+      REAL               ONE, ZERO, BIGNUM
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0,
+     $                     BIGNUM = 1.0E+38 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          DIST, TYPE
+      CHARACTER*3        PATH
+      INTEGER            I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO,
+     $                   INB, IND_OFFSET_GEN,
+     $                   IND_IN, IND_OUT, INS, INFO,
+     $                   ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO,
+     $                   KFACT, KL, KMAX, KU, LDA, LW, LWORK,
+     $                   LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N,
+     $                   NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS,
+     $                   NRUN, NX, T
+      REAL               ANORM, CNDNUM, EPS, ABSTOL, RELTOL,
+     $                   DTEMP, MAXC2NRMK, RELMAXC2NRMK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 ), ISEEDY( 4 )
+      REAL               RESULT( NTESTS ), RDUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SQPT01, SQRT11, SQRT12, SLANGE
+      EXTERNAL           SLAMCH, SQPT01, SQRT11, SQRT12, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ALAERH, ALAHD, ALASUM, SAXPY, SGEQP3RK,
+     $                   SLACPY, SLAORD, SLASET, SLATB4, SLATMS,
+     $                   SORMQR, SSWAP, ICOPY, XLAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, MOD, REAL
+*     ..
+*     .. Scalars in Common ..
+      LOGICAL            LERR, OK
+      CHARACTER*32       SRNAMT
+      INTEGER            INFOT, IOUNIT
+*     ..
+*     .. Common blocks ..
+      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
+      COMMON             / SRNAMC / SRNAMT
+*     ..
+*     .. Data statements ..
+      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize constants and the random number seed.
+*
+      PATH( 1: 1 ) = 'Single precision'
+      PATH( 2: 3 ) = 'QK'
+      NRUN = 0
+      NFAIL = 0
+      NERRS = 0
+      DO I = 1, 4
+         ISEED( I ) = ISEEDY( I )
+      END DO
+      EPS = SLAMCH( 'Epsilon' )
+      INFOT = 0
+*
+      DO IM = 1, NM
+*
+*        Do for each value of M in MVAL.
+*
+         M = MVAL( IM )
+         LDA = MAX( 1, M )
+*
+         DO IN = 1, NN
+*
+*           Do for each value of N in NVAL.
+*
+            N = NVAL( IN )
+            MINMN = MIN( M, N )
+            LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ),
+     $                   M*N + 2*MINMN + 4*N )
+*
+            DO INS = 1, NNS
+               NRHS = NSVAL( INS )
+*
+*                 Set up parameters with SLATB4 and generate
+*                 M-by-NRHS B matrix with SLATMS.
+*                 IMAT = 14:
+*                 Random matrix, CNDNUM = 2, NORM = ONE,
+*                 MODE = 3 (geometric distribution of singular values).
+*
+                  CALL SLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'SLATMS'
+                  CALL SLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYB, LDA, WORK, INFO )
+
+
+*
+*                 Check error code from SLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M,
+     $                            NRHS, -1, -1, -1, 6, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+               DO IMAT = 1, NTYPES
+*
+*              Do the tests only if DOTYPE( IMAT ) is true.
+*
+               IF( .NOT.DOTYPE( IMAT ) )
+     $            CYCLE
+*
+*              The type of distribution used to generate the random
+*              eigen-/singular values:
+*              ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 )
+*
+*           Do for each type of NON-SYMMETRIC matrix:                               CNDNUM                     NORM                                     MODE
+*            1. Zero matrix
+*            2. Random, Diagonal, CNDNUM = 2                                        CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            3. Random, Upper triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            4. Random, Lower triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            5. Random, First column is zero, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            6. Random, Last MINMN column is zero, CNDNUM = 2                       CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            7. Random, Last N column is zero, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            8. Random, Middle column in MINMN is zero, CNDNUM = 2                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            9. Random, First half of MINMN columns are zero, CNDNUM = 2            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2   CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           11. Random, Half MINMN columns in the middle are zero starting
+*                  from  MINMN/2-(MINMN/2)/2+1, CNDNUM = 2                          CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           12. Random, Odd columns are ZERO, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           13. Random, Even columns are ZERO, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           14. Random, CNDNUM = 2                                                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           15. Random, CNDNUM = sqrt(0.1/EPS)                                      CNDNUM = BADC1 = sqrt(0.1/EPS)  ONE                                      3 ( geometric distribution of singular values )
+*           16. Random, CNDNUM = 0.1/EPS                                            CNDNUM = BADC2 = 0.1/EPS        ONE                                      3 ( geometric distribution of singular values )
+*           17. Random, CNDNUM = 0.1/EPS,                                           CNDNUM = BADC2 = 0.1/EPS        ONE                                      2 ( one small singular value, S(N)=1/CNDNUM )
+*                 one small singular value S(N)=1/CNDNUM
+*           18. Random, CNDNUM = 2, scaled near underflow                           CNDNUM = 2                      SMALL = SAFMIN
+*           19. Random, CNDNUM = 2, scaled near overflow                            CNDNUM = 2                      LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) )  3 ( geometric distribution of singular values )
+*
+               IF( IMAT.EQ.1 ) THEN
+*
+*                 Matrix 1: Zero matrix
+*
+                  CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
+                  DO I = 1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 )
+     $                  .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN
+*
+*                 Matrices 2-5.
+*
+*                 Set up parameters with SLATB4 and generate a test
+*                 matrix with SLATMS.
+*
+                  CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'SLATMS'
+                  CALL SLATMS( M, N, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYA, LDA, WORK, INFO )
+*
+*                 Check error code from SLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N,
+     $                            -1, -1, -1, IMAT, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+                  CALL SLAORD( 'Decreasing', MINMN, S, 1 )
+*
+               ELSE IF( MINMN.GE.2
+     $                  .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN
+*
+*                 Rectangular matrices 5-13 that contain zero columns,
+*                 only for matrices MINMN >=2.
+*
+*                 JB_ZERO is the column index of ZERO block.
+*                 NB_ZERO is the column block size of ZERO block.
+*                 NB_GEN is the column blcok size of the
+*                 generated block.
+*                 J_INC in the non_zero column index increment
+*                 for matrix 12 and 13.
+*                 J_FIRS_NZ is the index of the first non-zero
+*                 column.
+*
+                  IF( IMAT.EQ.5 ) THEN
+*
+*                    First column is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.6 ) THEN
+*
+*                    Last column MINMN is zero.
+*
+                     JB_ZERO = MINMN
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.7 ) THEN
+*
+*                    Last column N is zero.
+*
+                     JB_ZERO = N
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.8 ) THEN
+*
+*                    Middle column in MINMN is zero.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.9 ) THEN
+*
+*                    First half of MINMN columns is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.10 ) THEN
+*
+*                    Last columns are zero columns,
+*                    starting from (MINMN / 2 + 1) column.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = N - JB_ZERO + 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.11 ) THEN
+*
+*                    Half of the columns in the middle of MINMN
+*                    columns is zero, starting from
+*                    MINMN/2 - (MINMN/2)/2 + 1 column.
+*
+                     JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.12 ) THEN
+*
+*                    Odd-numbered columns are zero,
+*
+                     NB_GEN = N / 2
+                     NB_ZERO = N - NB_GEN
+                     J_INC = 2
+                     J_FIRST_NZ = 2
+*
+                  ELSE IF( IMAT.EQ.13 ) THEN
+*
+*                    Even-numbered columns are zero.
+*
+                     NB_ZERO = N / 2
+                     NB_GEN = N - NB_ZERO
+                     J_INC = 2
+                     J_FIRST_NZ = 1
+*
+                  END IF
+*
+*
+*                 1) Set the first NB_ZERO columns in COPYA(1:M,1:N)
+*                    to zero.
+*
+                  CALL SLASET( 'Full', M, NB_ZERO, ZERO, ZERO,
+     $                         COPYA, LDA )
+*
+*                    2) Generate an M-by-(N-NB_ZERO) matrix with the
+*                       chosen singular value distribution
+*                       in COPYA(1:M,NB_ZERO+1:N).
+*
+                  CALL SLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU,
+     $                         ANORM, MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'SLATMS'
+*
+                  IND_OFFSET_GEN = NB_ZERO * LDA
+*
+                  CALL SLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE,
+     $                        CNDNUM, ANORM, KL, KU, 'No packing',
+     $                        COPYA( IND_OFFSET_GEN + 1 ), LDA,
+     $                        WORK, INFO )
+*
+*                 Check error code from SLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M,
+     $                            NB_GEN, -1, -1, -1, IMAT, NFAIL,
+     $                            NERRS, NOUT )
+                     CYCLE
+                  END IF
+*
+*                 3) Swap the gererated colums from the right side
+*                 NB_GEN-size block in COPYA into correct column
+*                 positions.
+*
+                  IF( IMAT.EQ.6
+     $                    .OR. IMAT.EQ.7
+     $                    .OR. IMAT.EQ.8
+     $                    .OR. IMAT.EQ.10
+     $                    .OR. IMAT.EQ.11 ) THEN
+*
+*                    Move by swapping the generated columns
+*                    from the right NB_GEN-size block from
+*                    (NB_ZERO+1:NB_ZERO+JB_ZERO)
+*                    into columns (1:JB_ZERO-1).
+*
+                     DO J = 1, JB_ZERO-1, 1
+                        CALL SSWAP( M,
+     $                        COPYA( ( NB_ZERO+J-1)*LDA+1), 1,
+     $                        COPYA( (J-1)*LDA + 1 ), 1 )
+                     END DO
+*
+                  ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN
+*
+*                    ( IMAT = 12, Odd-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the even zero colums in the
+*                    left NB_ZERO-size block.
+*
+*                    ( IMAT = 13, Even-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the odd zero colums in the
+*                    left NB_ZERO-size block.
+*
+                     DO J = 1, NB_GEN, 1
+                        IND_OUT = ( NB_ZERO+J-1 )*LDA + 1
+                        IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA
+     $                            + 1
+                        CALL SSWAP( M,
+     $                              COPYA( IND_OUT ), 1,
+     $                              COPYA( IND_IN), 1 )
+                        END DO
+*
+                  END IF
+*
+*                 5) Order the singular values generated by
+*                    DLAMTS in decreasing order and add trailing zeros
+*                    that correspond to zero columns.
+*                    The total number of singular values is MINMN.
+*
+                  MINMNB_GEN = MIN( M, NB_GEN )
+*
+                  DO I = MINMNB_GEN+1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE
+*
+*                    IF(MINMN.LT.2) skip this size for this matrix type.
+*
+                     CYCLE
+               END IF
+*
+*              Initialize a copy array for a pivot array for SGEQP3RK.
+*
+               DO I = 1, N
+                  IWORK( I ) = 0
+               END DO
+*
+               DO INB = 1, NNB
+*
+*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
+*
+                  NB = NBVAL( INB )
+                  CALL XLAENV( 1, NB )
+                  NX = NXVAL( INB )
+                  CALL XLAENV( 3, NX )
+*
+*                 We do MIN(M,N)+1 because we need a test for KMAX > N,
+*                 when KMAX is larger than MIN(M,N), KMAX should be
+*                 KMAX = MIN(M,N)
+*
+                  DO KMAX = 0, MIN(M,N)+1
+*
+*                 Get a working copy of COPYA into A( 1:M,1:N ).
+*                 Get a working copy of COPYB into A( 1:M, (N+1):NRHS ).
+*                 Get a working copy of COPYB into into B( 1:M, 1:NRHS ).
+*                 Get a working copy of IWORK(1:N) awith zeroes into
+*                 which is going to be used as pivot array IWORK( N+1:2N ).
+*                 NOTE: IWORK(2N+1:3N) is going to be used as a WORK array
+*                 for the routine.
+*
+                  CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
+                  CALL SLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         A( LDA*N + 1 ),  LDA )
+                  CALL SLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         B,  LDA )
+                  CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
+*
+                  ABSTOL = -1.0
+                  RELTOL = -1.0
+*
+*                 Compute the QR factorization with pivoting of A
+*
+                  LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ),
+     $                              3*N + NRHS - 1 ) )
+*
+*                 Compute SGEQP3RK factorization of A.
+*
+                  SRNAMT = 'SGEQP3RK'
+                  CALL SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                           A, LDA, KFACT, MAXC2NRMK,
+     $                           RELMAXC2NRMK, IWORK( N+1 ), TAU,
+     $                           WORK, LW, IWORK( 2*N+1 ), INFO )
+*
+*                 Check error code from SGEQP3RK.
+*
+                  IF( INFO.LT.0 )
+     $               CALL ALAERH( PATH, 'SGEQP3RK', INFO, 0, ' ',
+     $                            M, N, NX, -1, NB, IMAT,
+     $                            NFAIL, NERRS, NOUT )
+*
+*                 Compute test 1:
+*
+*                 This test in only for the full rank factorization of
+*                 the matrix A.
+*
+*                 Array S(1:min(M,N)) contains svd(A) the sigular values
+*                 of the original matrix A in decreasing absolute value
+*                 order. The test computes svd(R), the vector sigular
+*                 values of the upper trapezoid of A(1:M,1:N) that
+*                 contains the factor R, in decreasing order. The test
+*                 returns the ratio:
+*
+*                 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
+*
+                  IF( KFACT.EQ.MINMN ) THEN
+*
+                     RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK,
+     $                                     LWORK )
+*
+                     DO T = 1, 1
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL, NB, NX,
+     $                        IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                   End test 1
+*
+                  END IF
+*
+*                 Compute test 2:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
+*
+                  RESULT( 2 ) = SQPT01( M, N, KFACT, COPYA, A, LDA, TAU,
+     $                          IWORK( N+1 ), WORK, LWORK )
+*
+*                 Compute test 3:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( Q**T * Q - I ) / ( M * EPS )
+*
+                  RESULT( 3 ) = SQRT11( M, KFACT, A, LDA, TAU, WORK,
+     $                          LWORK )
+*
+*                 Print information about the tests that did not pass
+*                 the threshold.
+*
+                  DO T = 2, 3
+                     IF( RESULT( T ).GE.THRESH ) THEN
+                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                     CALL ALAHD( NOUT, PATH )
+                        WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N,
+     $                      NRHS, KMAX, ABSTOL, RELTOL,
+     $                      NB, NX, IMAT, T, RESULT( T )
+                        NFAIL = NFAIL + 1
+                     END IF
+                  END DO
+                  NRUN = NRUN + 2
+*
+*                 Compute test 4:
+*
+*                 This test is only for the factorizations with the
+*                 rank greater than 2.
+*                 The elements on the diagonal of R should be non-
+*                 increasing.
+*
+*                 The test returns the ratio:
+*
+*                 Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
+*                 K=1:KFACT-1
+*
+                  IF( MIN(KFACT, MINMN).GE.2 ) THEN
+*
+                     DO J = 1, KFACT-1, 1
+
+                        DTEMP = (( ABS( A( (J-1)*M+J ) ) -
+     $                          ABS( A( (J)*M+J+1 ) ) ) /
+     $                          ABS( A(1) ) )
+*
+                        IF( DTEMP.LT.ZERO ) THEN
+                           RESULT( 4 ) = BIGNUM
+                        END IF
+*
+                     END DO
+*
+*                    Print information about the tests that did not
+*                    pass the threshold.
+*
+                     DO T = 4, 4
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK',
+     $                        M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T,
+     $                        RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End test 4.
+*
+                  END IF
+*
+*                 Compute test 5:
+*
+*                 This test in only for matrix A with min(M,N) > 0.
+*
+*                 The test returns the ratio:
+*
+*                 1-norm(Q**T * B - Q**T * B ) /
+*                       ( M * EPS )
+*
+*                 (1) Compute B:=Q**T * B in the matrix B.
+*
+                  IF( MINMN.GT.0 ) THEN
+*
+                     LWORK_MQR = MAX(1, NRHS)
+                     CALL SORMQR( 'Left', 'Transpose',
+     $                         M, NRHS, KFACT, A, LDA, TAU, B, LDA,
+     $                         WORK, LWORK_MQR, INFO )
+*
+                     DO I = 1, NRHS
+*
+*                       Compare N+J-th column of A and J-column of B.
+*
+                        CALL SAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1,
+     $                                 B( ( I-1 )*LDA+1 ), 1 )
+                     END DO
+*
+                   RESULT( 5 ) =
+     $               ABS(
+     $               SLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) /
+     $               ( REAL( M )*SLAMCH( 'Epsilon' ) )
+     $               )
+*
+*                    Print information about the tests that did not pass
+*                    the threshold.
+*
+                     DO T = 5, 5
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End compute test 5.
+*
+                  END IF
+*
+*                 END DO KMAX = 1, MIN(M,N)+1
+*
+                  END DO
+*
+*                 END DO for INB = 1, NNB
+*
+               END DO
+*
+*              END DO  for IMAT = 1, NTYPES
+*
+               END DO
+*
+*              END DO for INS = 1, NNS
+*
+            END DO
+*
+*           END DO for IN = 1, NN
+*
+         END DO
+*
+*        END DO for IM = 1, NM
+*
+      END DO
+*
+*     Print a summary of the results.
+*
+      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5,
+     $        ', KMAX =', I5, ', ABSTOL =', G12.5,
+     $        ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4,
+     $        ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
+*
+*     End of SCHKQP3RK
+*
+      END

lapack-netlib/TESTING/LIN/slatb4.f

@@ -153,9 +153,6 @@
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, SQRT
 *     ..
-*     .. External Subroutines ..
-      EXTERNAL           SLABAD
-*     ..
 *     .. Save statement ..
       SAVE               EPS, SMALL, LARGE, BADC1, BADC2, FIRST
 *     ..
@@ -173,11 +170,6 @@
          BADC1 = SQRT( BADC2 )
          SMALL = SLAMCH( 'Safe minimum' )
          LARGE = ONE / SMALL
-*
-*        If it looks like we're on a Cray, take the square root of
-*        SMALL and LARGE to avoid overflow and underflow problems.
-*
-         CALL SLABAD( SMALL, LARGE )
          SMALL = SHRINK*( SMALL / EPS )
          LARGE = ONE / SMALL
       END IF
@@ -232,6 +224,110 @@
          ELSE
             ANORM = ONE
          END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        xQK: truncated QR with pivoting.
+*             Set parameters to generate a general
+*             M x N matrix.
+*
+*        Set TYPE, the type of matrix to be generated.  'N' is nonsymmetric.
+*
+         TYPE = 'N'
+*
+*        Set DIST, the type of distribution for the random
+*        number generator. 'S' is
+*
+         DIST = 'S'
+*
+*        Set the lower and upper bandwidths.
+*
+         IF( IMAT.EQ.2 ) THEN
+*
+*           2. Random, Diagonal, CNDNUM = 2
+*
+            KL = 0
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.3 ) THEN
+*
+*           3. Random, Upper triangular,  CNDNUM = 2
+*
+            KL = 0
+            KU = MAX( N-1, 0 )
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.4 ) THEN
+*
+*          4. Random, Lower triangular,  CNDNUM = 2
+*
+            KL = MAX( M-1, 0 )
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE
+*
+*           5.-19. Rectangular matrix
+*
+            KL = MAX( M-1, 0 )
+            KU = MAX( N-1, 0 )
+*
+            IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN
+*
+*              5.-14. Random, CNDNUM = 2.
+*
+               CNDNUM = TWO
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.15 ) THEN
+*
+*              15. Random, CNDNUM = sqrt(0.1/EPS)
+*
+               CNDNUM = BADC1
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.16 ) THEN
+*
+*              16. Random, CNDNUM = 0.1/EPS
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.17 ) THEN
+*
+*              17. Random, CNDNUM = 0.1/EPS,
+*                  one small singular value S(N)=1/CNDNUM
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 2
+*
+            ELSE IF( IMAT.EQ.18 ) THEN
+*
+*              18. Random, scaled near underflow
+*
+               CNDNUM = TWO
+               ANORM = SMALL
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.19 ) THEN
+*
+*              19. Random, scaled near overflow
+*
+               CNDNUM = TWO
+               ANORM = LARGE
+               MODE = 3
+*
+            END IF
+*
+         END IF
 *
       ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
 *
@@ -518,17 +614,18 @@
 *
 *        Set the norm and condition number.
 *
-         IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN
+         MAT = ABS( IMAT )
+         IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN
             CNDNUM = BADC1
-         ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN
+         ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN
             CNDNUM = BADC2
          ELSE
             CNDNUM = TWO
          END IF
 *
-         IF( IMAT.EQ.4 ) THEN
+         IF( MAT.EQ.4 ) THEN
             ANORM = SMALL
-         ELSE IF( IMAT.EQ.5 ) THEN
+         ELSE IF( MAT.EQ.5 ) THEN
             ANORM = LARGE
          ELSE
             ANORM = ONE

lapack-netlib/TESTING/LIN/sqpt01.f

@@ -33,7 +33,8 @@
 *> Householder vectors, and the rest of AF contains a partially updated
 *> matrix.
 *>
-*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
+*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) )
+*> where || . || is matrix one norm.
 *> \endverbatim
 *
 *  Arguments:
@@ -172,28 +173,28 @@
 *
       NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK )
 *
-      DO 30 J = 1, K
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, K
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = AF( I, J )
-   10    CONTINUE
-         DO 20 I = J + 1, M
+         END DO
+         DO I = J + 1, M
             WORK( ( J-1 )*M+I ) = ZERO
-   20    CONTINUE
-   30 CONTINUE
-      DO 40 J = K + 1, N
+         END DO
+      END DO
+      DO J = K + 1, N
          CALL SCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 )
-   40 CONTINUE
+      END DO
 *
       CALL SORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK,
      $             M, WORK( M*N+1 ), LWORK-M*N, INFO )
 *
-      DO 50 J = 1, N
+      DO J = 1, N
 *
 *        Compare i-th column of QR and jpvt(i)-th column of A
 *
          CALL SAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ),
      $               1 )
-   50 CONTINUE
+      END DO
 *
       SQPT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK ) /
      $         ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/sqrt11.f

@@ -157,9 +157,9 @@
       CALL SORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M,
      $             WORK( M*M+1 ), INFO )
 *
-      DO 10 J = 1, M
+      DO J = 1, M
          WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE
-   10 CONTINUE
+      END DO
 *
       SQRT11 = SLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) /
      $         ( REAL( M )*SLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/sqrt12.f

@@ -26,7 +26,7 @@
 *> SQRT12 computes the singular values `svlues' of the upper trapezoid
 *> of A(1:M,1:N) and returns the ratio
 *>
-*>      || s - svlues||/(||svlues||*eps*max(M,N))
+*>      || svlues - s ||/(||s||*eps*max(M,N))
 *> \endverbatim
 *
 *  Arguments:
@@ -113,8 +113,7 @@
       EXTERNAL           SASUM, SLAMCH, SLANGE, SNRM2
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SAXPY, SBDSQR, SGEBD2, SLABAD, SLASCL, SLASET,
-     $                   XERBLA
+      EXTERNAL           SAXPY, SBDSQR, SGEBD2, SLASCL, SLASET, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN, REAL
@@ -145,17 +144,16 @@
 *     Copy upper triangle of A into work
 *
       CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
-      DO 20 J = 1, N
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, N
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = A( I, J )
-   10    CONTINUE
-   20 CONTINUE
+         END DO
+      END DO
 *
 *     Get machine parameters
 *
       SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
       BIGNUM = ONE / SMLNUM
-      CALL SLABAD( SMLNUM, BIGNUM )
 *
 *     Scale work if max entry outside range [SMLNUM,BIGNUM]
 *
@@ -199,9 +197,9 @@
 *
       ELSE
 *
-         DO 30 I = 1, MN
+         DO I = 1, MN
             WORK( M*N+I ) = ZERO
-   30    CONTINUE
+         END DO
       END IF
 *
 *     Compare s and singular values of work

lapack-netlib/TESTING/LIN/zchkaa.F

@@ -69,6 +69,7 @@
 *> ZLQ    8               List types on next line if 0 < NTYPES <  8
 *> ZQL    8               List types on next line if 0 < NTYPES <  8
 *> ZQP    6               List types on next line if 0 < NTYPES <  6
+*> ZQK   19               List types on next line if 0 < NTYPES < 19
 *> ZTZ    3               List types on next line if 0 < NTYPES <  3
 *> ZLS    6               List types on next line if 0 < NTYPES <  6
 *> ZEQ
@@ -153,12 +154,11 @@
      $                   NBVAL( MAXIN ), NBVAL2( MAXIN ),
      $                   NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
      $                   RANKVAL( MAXIN ), PIV( NMAX )
-      DOUBLE PRECISION   S( 2*NMAX )
-      COMPLEX*16         E( NMAX )
-*
-*    .. Allocatable Arrays ..
+*     ..
+*     .. Allocatable Arrays ..
       INTEGER AllocateStatus
-      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE::   RWORK
+      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE::  RWORK, S
+      COMPLEX*16, DIMENSION(:), ALLOCATABLE :: E
       COMPLEX*16, DIMENSION(:,:), ALLOCATABLE::  A, B, WORK
 *     ..
 *     .. External Functions ..
@@ -170,15 +170,16 @@
       EXTERNAL           ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE,
      $                   ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP,
      $                   ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS,
-     $                   ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ,
-     $                   ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK,
-     $                   ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ,
-     $                   ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK,
-     $                   ZDRVHE_RK, ZDRVHE_AA, ZDRVHE_AA_2STAGE, ZDRVHP,
-     $                   ZDRVLS, ZDRVPB,  ZDRVPO, ZDRVPP, ZDRVPT,
-     $                   ZDRVSP, ZDRVSY, ZDRVSY_ROOK, ZDRVSY_RK,
-     $                   ZDRVSY_AA, ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT,
-     $                   ZCHKQRTP, ZCHKLQT, ZCHKLQTP, ZCHKTSQR
+     $                   ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQP3RK, ZCHKQL,
+     $                   ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK,
+     $                   ZCHKSY_RK, ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR,
+     $                   ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE,
+     $                   ZDRVHE_ROOK, ZDRVHE_RK, ZDRVHE_AA,
+     $                   ZDRVHE_AA_2STAGE, ZDRVHP, ZDRVLS, ZDRVPB,
+     $                   ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY,
+     $                   ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA,
+     $                   ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP,
+     $                   ZCHKLQT, ZCHKLQTP, ZCHKTSQR
 *     ..
 *     .. Scalars in Common ..
       LOGICAL            LERR, OK
@@ -197,13 +198,18 @@
       DATA               THREQ / 2.0D0 / , INTSTR / '0123456789' /
 *
 *     .. Allocate memory dynamically ..
-      ALLOCATE (RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus)
+*
+      ALLOCATE ( A ( (KDMAX+1) * NMAX, 7 ), STAT = AllocateStatus)
+      IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
+      ALLOCATE ( B ( NMAX * MAXRHS, 4 ), STAT = AllocateStatus)
+      IF (AllocateStatus /= 0 ) STOP "*** Not enough memory ***"
+      ALLOCATE ( WORK ( NMAX, NMAX+MAXRHS+10 ), STAT = AllocateStatus)
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
-      ALLOCATE (A ((KDMAX+1) * NMAX, 7), STAT = AllocateStatus)
+      ALLOCATE ( E( NMAX ), STAT = AllocateStatus )
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
-      ALLOCATE (B (NMAX * MAXRHS, 4), STAT = AllocateStatus)
+      ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus)
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
-      ALLOCATE (WORK (NMAX, NMAX+MAXRHS+10), STAT = AllocateStatus)
+      ALLOCATE ( RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus)
       IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
 *     ..
 *     .. Executable Statements ..
@@ -1109,6 +1115,23 @@
          ELSE
             WRITE( NOUT, FMT = 9989 )PATH
          END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        QK: truncated QR factorization with pivoting
+*
+         NTYPES = 19
+         CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+         IF( TSTCHK ) THEN
+            CALL ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                   NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ),
+     $                   A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+     $                   S( 1 ), B( 1, 4 ),
+     $                   WORK, RWORK, IWORK, NOUT )
+         ELSE
+            WRITE( NOUT, FMT = 9989 )PATH
+         END IF
 *
       ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
 *

lapack-netlib/TESTING/LIN/zchkqp3rk.f

@@ -0,0 +1,836 @@
+*> \brief \b ZCHKQP3RK
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*      SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+*     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+*     $                      B, COPYB, S, TAU,
+*     $                      WORK, RWORK, IWORK, NOUT )
+*      IMPLICIT NONE
+*
+*       .. Scalar Arguments ..
+*       INTEGER            NM, NN, NNB, NOUT
+*       DOUBLE PRECISION   THRESH
+*       ..
+*       .. Array Arguments ..
+*       LOGICAL            DOTYPE( * )
+*       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
+*      $                   NXVAL( * )
+*       DOUBLE PRECISION   S( * ), RWORK( * )
+*       COMPLEX*16         A( * ), COPYA( * ), TAU( * ), WORK( * )
+*       ..
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*> ZCHKQP3RK tests ZGEQP3RK.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*>          DOTYPE is LOGICAL array, dimension (NTYPES)
+*>          The matrix types to be used for testing.  Matrices of type j
+*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*>          NM is INTEGER
+*>          The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*>          MVAL is INTEGER array, dimension (NM)
+*>          The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*>          NN is INTEGER
+*>          The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*>          NVAL is INTEGER array, dimension (NN)
+*>          The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] 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] NNB
+*> \verbatim
+*>          NNB is INTEGER
+*>          The number of values of NB and NX contained in the
+*>          vectors NBVAL and NXVAL.  The blocking parameters are used
+*>          in pairs (NB,NX).
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*>          NBVAL is INTEGER array, dimension (NNB)
+*>          The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NXVAL
+*> \verbatim
+*>          NXVAL is INTEGER array, dimension (NNB)
+*>          The values of the crossover point NX.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*>          THRESH is DOUBLE PRECISION
+*>          The threshold value for the test ratios.  A result is
+*>          included in the output file if RESULT >= THRESH.  To have
+*>          every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*>          A is COMPLEX*16 array, dimension (MMAX*NMAX)
+*>          where MMAX is the maximum value of M in MVAL and NMAX is the
+*>          maximum value of N in NVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYA
+*> \verbatim
+*>          COPYA is COMPLEX*16 array, dimension (MMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*>          B is COMPLEX*16 array, dimension (MMAX*NSMAX)
+*>          where MMAX is the maximum value of M in MVAL and NSMAX is the
+*>          maximum value of NRHS in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] COPYB
+*> \verbatim
+*>          COPYB is COMPLEX*16 array, dimension (MMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] S
+*> \verbatim
+*>          S is DOUBLE PRECISION array, dimension
+*>                      (min(MMAX,NMAX))
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*>          TAU is COMPLEX*16 array, dimension (MMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*>          WORK is COMPLEX*16 array, dimension
+*>                      (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*>          RWORK is DOUBLE PRECISION array, dimension (4*NMAX)
+*> \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.
+*
+*> \ingroup complex16_lin
+*
+*  =====================================================================
+      SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
+     $                      NNB, NBVAL, NXVAL, THRESH, A, COPYA,
+     $                      B, COPYB, S, TAU,
+     $                      WORK, RWORK, IWORK, NOUT )
+      IMPLICIT NONE
+*
+*  -- LAPACK test routine --
+*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*     .. Scalar Arguments ..
+      INTEGER            NM, NN, NNB, NNS, NOUT
+      DOUBLE PRECISION   THRESH
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            DOTYPE( * )
+      INTEGER            IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ),
+     $                   NSVAL( * ), NXVAL( * )
+      DOUBLE PRECISION   S( * ), RWORK( * )
+      COMPLEX*16         A( * ), COPYA( * ), B( * ), COPYB( * ),
+     $                   TAU( * ), WORK( * )
+*     ..
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NTYPES
+      PARAMETER          ( NTYPES = 19 )
+      INTEGER            NTESTS
+      PARAMETER          ( NTESTS = 5 )
+      DOUBLE PRECISION   ONE, ZERO, BIGNUM
+      COMPLEX*16         CONE, CZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0,
+     $                   CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ),
+     $                   BIGNUM = 1.0D+38 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          DIST, TYPE
+      CHARACTER*3        PATH
+      INTEGER            I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO,
+     $                   INB, IND_OFFSET_GEN,
+     $                   IND_IN, IND_OUT, INS, INFO,
+     $                   ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO,
+     $                   KFACT, KL, KMAX, KU, LDA, LW, LWORK,
+     $                   LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N,
+     $                   NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS,
+     $                   NRUN, NX, T
+      DOUBLE PRECISION   ANORM, CNDNUM, EPS, ABSTOL, RELTOL,
+     $                   DTEMP, MAXC2NRMK, RELMAXC2NRMK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 ), ISEEDY( 4 )
+      DOUBLE PRECISION   RESULT( NTESTS ), RDUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, ZQPT01, ZQRT11, ZQRT12, ZLANGE
+      EXTERNAL           DLAMCH, ZQPT01, ZQRT11, ZQRT12, ZLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ALAERH, ALAHD, ALASUM, DLAORD, ICOPY, ZAXPY,
+     $                   XLAENV, ZGEQP3RK, ZLACPY, ZLASET, ZLATB4,
+     $                   ZLATMS, ZUNMQR, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, MOD
+*     ..
+*     .. Scalars in Common ..
+      LOGICAL            LERR, OK
+      CHARACTER*32       SRNAMT
+      INTEGER            INFOT, IOUNIT, ZUNMQR_LWORK
+*     ..
+*     .. Common blocks ..
+      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
+      COMMON             / SRNAMC / SRNAMT
+*     ..
+*     .. Data statements ..
+      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize constants and the random number seed.
+*
+      PATH( 1: 1 ) = 'Zomplex precision'
+      PATH( 2: 3 ) = 'QK'
+      NRUN = 0
+      NFAIL = 0
+      NERRS = 0
+      DO  I = 1, 4
+         ISEED( I ) = ISEEDY( I )
+      END DO
+      EPS = DLAMCH( 'Epsilon' )
+      INFOT = 0
+*
+      DO IM = 1, NM
+*
+*        Do for each value of M in MVAL.
+*
+         M = MVAL( IM )
+         LDA = MAX( 1, M )
+*
+         DO IN = 1, NN
+*
+*           Do for each value of N in NVAL.
+*
+            N = NVAL( IN )
+            MINMN = MIN( M, N )
+            LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ),
+     $                   M*N + 2*MINMN + 4*N )
+*
+            DO INS = 1, NNS
+               NRHS = NSVAL( INS )
+*
+*                 Set up parameters with ZLATB4 and generate
+*                 M-by-NRHS B matrix with ZLATMS.
+*                 IMAT = 14:
+*                 Random matrix, CNDNUM = 2, NORM = ONE,
+*                 MODE = 3 (geometric distribution of singular values).
+*
+                  CALL ZLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'ZLATMS'
+                  CALL ZLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYB, LDA, WORK, INFO )
+*
+*                 Check error code from ZLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M,
+     $                            NRHS, -1, -1, -1, 6, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+               DO IMAT = 1, NTYPES
+*
+*              Do the tests only if DOTYPE( IMAT ) is true.
+*
+               IF( .NOT.DOTYPE( IMAT ) )
+     $            CYCLE
+*
+*              The type of distribution used to generate the random
+*              eigen-/singular values:
+*              ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 )
+*
+*           Do for each type of NON-SYMMETRIC matrix:                               CNDNUM                     NORM                                     MODE
+*            1. Zero matrix
+*            2. Random, Diagonal, CNDNUM = 2                                        CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            3. Random, Upper triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            4. Random, Lower triangular, CNDNUM = 2                                CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            5. Random, First column is zero, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            6. Random, Last MINMN column is zero, CNDNUM = 2                       CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            7. Random, Last N column is zero, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            8. Random, Middle column in MINMN is zero, CNDNUM = 2                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*            9. Random, First half of MINMN columns are zero, CNDNUM = 2            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2   CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           11. Random, Half MINMN columns in the middle are zero starting
+*                  from  MINMN/2-(MINMN/2)/2+1, CNDNUM = 2                          CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           12. Random, Odd columns are ZERO, CNDNUM = 2                            CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           13. Random, Even columns are ZERO, CNDNUM = 2                           CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           14. Random, CNDNUM = 2                                                  CNDNUM = 2                      ONE                                      3 ( geometric distribution of singular values )
+*           15. Random, CNDNUM = sqrt(0.1/EPS)                                      CNDNUM = BADC1 = sqrt(0.1/EPS)  ONE                                      3 ( geometric distribution of singular values )
+*           16. Random, CNDNUM = 0.1/EPS                                            CNDNUM = BADC2 = 0.1/EPS        ONE                                      3 ( geometric distribution of singular values )
+*           17. Random, CNDNUM = 0.1/EPS,                                           CNDNUM = BADC2 = 0.1/EPS        ONE                                      2 ( one small singular value, S(N)=1/CNDNUM )
+*                 one small singular value S(N)=1/CNDNUM
+*           18. Random, CNDNUM = 2, scaled near underflow                           CNDNUM = 2                      SMALL = SAFMIN
+*           19. Random, CNDNUM = 2, scaled near overflow                            CNDNUM = 2                      LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) )  3 ( geometric distribution of singular values )
+*
+               IF( IMAT.EQ.1 ) THEN
+*
+*                 Matrix 1: Zero matrix
+*
+                  CALL ZLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA )
+                  DO I = 1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 )
+     $                  .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN
+*
+*                 Matrices 2-5.
+*
+*                 Set up parameters with DLATB4 and generate a test
+*                 matrix with ZLATMS.
+*
+                  CALL ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM,
+     $                         MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'ZLATMS'
+                  CALL ZLATMS( M, N, DIST, ISEED, TYPE, S, MODE,
+     $                         CNDNUM, ANORM, KL, KU, 'No packing',
+     $                         COPYA, LDA, WORK, INFO )
+*
+*                 Check error code from ZLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, N,
+     $                            -1, -1, -1, IMAT, NFAIL, NERRS,
+     $                            NOUT )
+                     CYCLE
+                  END IF
+*
+                  CALL DLAORD( 'Decreasing', MINMN, S, 1 )
+*
+               ELSE IF( MINMN.GE.2
+     $                  .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN
+*
+*                 Rectangular matrices 5-13 that contain zero columns,
+*                 only for matrices MINMN >=2.
+*
+*                 JB_ZERO is the column index of ZERO block.
+*                 NB_ZERO is the column block size of ZERO block.
+*                 NB_GEN is the column blcok size of the
+*                 generated block.
+*                 J_INC in the non_zero column index increment
+*                 for matrix 12 and 13.
+*                 J_FIRS_NZ is the index of the first non-zero
+*                 column.
+*
+                  IF( IMAT.EQ.5 ) THEN
+*
+*                    First column is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.6 ) THEN
+*
+*                    Last column MINMN is zero.
+*
+                     JB_ZERO = MINMN
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.7 ) THEN
+*
+*                    Last column N is zero.
+*
+                     JB_ZERO = N
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.8 ) THEN
+*
+*                    Middle column in MINMN is zero.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.9 ) THEN
+*
+*                    First half of MINMN columns is zero.
+*
+                     JB_ZERO = 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.10 ) THEN
+*
+*                    Last columns are zero columns,
+*                    starting from (MINMN / 2 + 1) column.
+*
+                     JB_ZERO = MINMN / 2 + 1
+                     NB_ZERO = N - JB_ZERO + 1
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.11 ) THEN
+*
+*                    Half of the columns in the middle of MINMN
+*                    columns is zero, starting from
+*                    MINMN/2 - (MINMN/2)/2 + 1 column.
+*
+                     JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1
+                     NB_ZERO = MINMN / 2
+                     NB_GEN = N - NB_ZERO
+*
+                  ELSE IF( IMAT.EQ.12 ) THEN
+*
+*                    Odd-numbered columns are zero,
+*
+                     NB_GEN = N / 2
+                     NB_ZERO = N - NB_GEN
+                     J_INC = 2
+                     J_FIRST_NZ = 2
+*
+                  ELSE IF( IMAT.EQ.13 ) THEN
+*
+*                    Even-numbered columns are zero.
+*
+                     NB_ZERO = N / 2
+                     NB_GEN = N - NB_ZERO
+                     J_INC = 2
+                     J_FIRST_NZ = 1
+*
+                  END IF
+*
+*
+*                 1) Set the first NB_ZERO columns in COPYA(1:M,1:N)
+*                    to zero.
+*
+                  CALL ZLASET( 'Full', M, NB_ZERO, CZERO, CZERO,
+     $                         COPYA, LDA )
+*
+*                    2) Generate an M-by-(N-NB_ZERO) matrix with the
+*                       chosen singular value distribution
+*                       in COPYA(1:M,NB_ZERO+1:N).
+*
+                  CALL ZLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU,
+     $                         ANORM, MODE, CNDNUM, DIST )
+*
+                  SRNAMT = 'ZLATMS'
+*
+                  IND_OFFSET_GEN = NB_ZERO * LDA
+*
+                  CALL ZLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE,
+     $                        CNDNUM, ANORM, KL, KU, 'No packing',
+     $                        COPYA( IND_OFFSET_GEN + 1 ), LDA,
+     $                        WORK, INFO )
+*
+*                 Check error code from ZLATMS.
+*
+                  IF( INFO.NE.0 ) THEN
+                     CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M,
+     $                            NB_GEN, -1, -1, -1, IMAT, NFAIL,
+     $                            NERRS, NOUT )
+                     CYCLE
+                  END IF
+*
+*                 3) Swap the gererated colums from the right side
+*                 NB_GEN-size block in COPYA into correct column
+*                 positions.
+*
+                  IF( IMAT.EQ.6
+     $                    .OR. IMAT.EQ.7
+     $                    .OR. IMAT.EQ.8
+     $                    .OR. IMAT.EQ.10
+     $                    .OR. IMAT.EQ.11 ) THEN
+*
+*                    Move by swapping the generated columns
+*                    from the right NB_GEN-size block from
+*                    (NB_ZERO+1:NB_ZERO+JB_ZERO)
+*                    into columns (1:JB_ZERO-1).
+*
+                     DO J = 1, JB_ZERO-1, 1
+                        CALL ZSWAP( M,
+     $                        COPYA( ( NB_ZERO+J-1)*LDA+1), 1,
+     $                        COPYA( (J-1)*LDA + 1 ), 1 )
+                     END DO
+*
+                  ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN
+*
+*                    ( IMAT = 12, Odd-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the even zero colums in the
+*                    left NB_ZERO-size block.
+*
+*                    ( IMAT = 13, Even-numbered ZERO columns. )
+*                    Swap the generated columns from the right
+*                    NB_GEN-size block into the odd zero colums in the
+*                    left NB_ZERO-size block.
+*
+                     DO J = 1, NB_GEN, 1
+                        IND_OUT = ( NB_ZERO+J-1 )*LDA + 1
+                        IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA
+     $                            + 1
+                        CALL ZSWAP( M,
+     $                              COPYA( IND_OUT ), 1,
+     $                              COPYA( IND_IN), 1 )
+                        END DO
+*
+                  END IF
+*
+*                 5) Order the singular values generated by
+*                    DLAMTS in decreasing order and add trailing zeros
+*                    that correspond to zero columns.
+*                    The total number of singular values is MINMN.
+*
+                  MINMNB_GEN = MIN( M, NB_GEN )
+*
+                  CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 )
+
+                  DO I = MINMNB_GEN+1, MINMN
+                     S( I ) = ZERO
+                  END DO
+*
+               ELSE
+*
+*                    IF(MINMN.LT.2) skip this size for this matrix type.
+*
+                     CYCLE
+               END IF
+*
+*              Initialize a copy array for a pivot array for DGEQP3RK.
+*
+               DO I = 1, N
+                  IWORK( I ) = 0
+               END DO
+*
+               DO INB = 1, NNB
+*
+*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
+*
+                  NB = NBVAL( INB )
+                  CALL XLAENV( 1, NB )
+                  NX = NXVAL( INB )
+                  CALL XLAENV( 3, NX )
+*
+*                 We do MIN(M,N)+1 because we need a test for KMAX > N,
+*                 when KMAX is larger than MIN(M,N), KMAX should be
+*                 KMAX = MIN(M,N)
+*
+                  DO KMAX = 0, MIN(M,N)+1
+*
+*                 Get a working copy of COPYA into A( 1:M,1:N ).
+*                 Get a working copy of COPYB into A( 1:M, (N+1):NRHS ).
+*                 Get a working copy of COPYB into into B( 1:M, 1:NRHS ).
+*                 Get a working copy of IWORK(1:N) awith zeroes into
+*                 which is going to be used as pivot array IWORK( N+1:2N ).
+*                 NOTE: IWORK(2N+1:3N) is going to be used as a WORK array
+*                 for the routine.
+*
+                  CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA )
+                  CALL ZLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         A( LDA*N + 1 ),  LDA )
+                  CALL ZLACPY( 'All', M, NRHS, COPYB, LDA,
+     $                         B,  LDA )
+                  CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
+*
+                  ABSTOL = -1.0
+                  RELTOl = -1.0
+*
+*                 Compute the QR factorization with pivoting of A
+*
+                  LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ),
+     $                              3*N + NRHS - 1 ) )
+*
+*                 Compute ZGEQP3RK factorization of A.
+*
+                  SRNAMT = 'ZGEQP3RK'
+                  CALL ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                           A, LDA, KFACT, MAXC2NRMK,
+     $                           RELMAXC2NRMK, IWORK( N+1 ), TAU,
+     $                           WORK, LW, RWORK, IWORK( 2*N+1 ),
+     $                           INFO )
+*
+*                 Check error code from ZGEQP3RK.
+*
+                  IF( INFO.LT.0 )
+     $               CALL ALAERH( PATH, 'ZGEQP3RK', INFO, 0, ' ',
+     $                            M, N, NX, -1, NB, IMAT,
+     $                            NFAIL, NERRS, NOUT )
+*
+                  IF( KFACT.EQ.MINMN ) THEN
+*
+*                 Compute test 1:
+*
+*                 This test in only for the full rank factorization of
+*                 the matrix A.
+*
+*                 Array S(1:min(M,N)) contains svd(A) the sigular values
+*                 of the original matrix A in decreasing absolute value
+*                 order. The test computes svd(R), the vector sigular
+*                 values of the upper trapezoid of A(1:M,1:N) that
+*                 contains the factor R, in decreasing order. The test
+*                 returns the ratio:
+*
+*                 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
+*
+                     RESULT( 1 ) = ZQRT12( M, N, A, LDA, S, WORK,
+     $                                     LWORK , RWORK )
+*
+                     DO T = 1, 1
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL, NB, NX,
+     $                        IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                   End test 1
+*
+                  END IF
+
+*                 Compute test 2:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
+*
+                  RESULT( 2 ) = ZQPT01( M, N, KFACT, COPYA, A, LDA, TAU,
+     $                          IWORK( N+1 ), WORK, LWORK )
+*
+*                 Compute test 3:
+*
+*                 The test returns the ratio:
+*
+*                 1-norm( Q**T * Q - I ) / ( M * EPS )
+*
+                  RESULT( 3 ) = ZQRT11( M, KFACT, A, LDA, TAU, WORK,
+     $                          LWORK )
+*
+*                 Print information about the tests that did not pass
+*                 the threshold.
+*
+                  DO T = 2, 3
+                     IF( RESULT( T ).GE.THRESH ) THEN
+                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                     CALL ALAHD( NOUT, PATH )
+                        WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N,
+     $                      NRHS, KMAX, ABSTOL, RELTOL,
+     $                      NB, NX, IMAT, T, RESULT( T )
+                        NFAIL = NFAIL + 1
+                     END IF
+                  END DO
+                  NRUN = NRUN + 2
+*
+*                 Compute test 4:
+*
+*                 This test is only for the factorizations with the
+*                 rank greater than 2.
+*                 The elements on the diagonal of R should be non-
+*                 increasing.
+*
+*                 The test returns the ratio:
+*
+*                 Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
+*                 K=1:KFACT-1
+*
+                  IF( MIN(KFACT, MINMN).GE.2 ) THEN
+*
+                     DO J = 1, KFACT-1, 1
+*
+                        DTEMP = (( ABS( A( (J-1)*M+J ) ) -
+     $                          ABS( A( (J)*M+J+1 ) ) ) /
+     $                          ABS( A(1) ) )
+*
+                        IF( DTEMP.LT.ZERO ) THEN
+                           RESULT( 4 ) = BIGNUM
+                        END IF
+*
+                     END DO
+*
+*                    Print information about the tests that did not
+*                    pass the threshold.
+*
+                     DO T = 4, 4
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK',
+     $                        M, N, NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T,
+     $                        RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End test 4.
+*
+                  END IF
+*
+*                 Compute test 5:
+*
+*                 This test in only for matrix A with min(M,N) > 0.
+*
+*                 The test returns the ratio:
+*
+*                 1-norm(Q**T * B - Q**T * B ) /
+*                       ( M * EPS )
+*
+*                 (1) Compute B:=Q**T * B in the matrix B.
+*
+                  IF( MINMN.GT.0 ) THEN
+*
+                     LWORK_MQR = MAX(1, NRHS)
+                     CALL ZUNMQR( 'Left', 'Conjugate transpose',
+     $                         M, NRHS, KFACT, A, LDA, TAU, B, LDA,
+     $                         WORK, LWORK_MQR, INFO )
+*
+                     DO I = 1, NRHS
+*
+*                       Compare N+J-th column of A and J-column of B.
+*
+                        CALL ZAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1,
+     $                                    B( ( I-1 )*LDA+1 ), 1 )
+                     END DO
+*
+                     RESULT( 5 ) =
+     $               ABS(
+     $               ZLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) /
+     $               ( DBLE( M )*DLAMCH( 'Epsilon' ) )
+     $               )
+*
+*                    Print information about the tests that did not pass
+*                    the threshold.
+*
+                     DO T = 5, 5
+                        IF( RESULT( T ).GE.THRESH ) THEN
+                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+     $                        CALL ALAHD( NOUT, PATH )
+                           WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N,
+     $                        NRHS, KMAX, ABSTOL, RELTOL,
+     $                        NB, NX, IMAT, T, RESULT( T )
+                           NFAIL = NFAIL + 1
+                        END IF
+                     END DO
+                     NRUN = NRUN + 1
+*
+*                    End compute test 5.
+*
+                  END IF
+*
+*                 END DO KMAX = 1, MIN(M,N)+1
+*
+                  END DO
+*
+*                 END DO for INB = 1, NNB
+*
+               END DO
+*
+*              END DO  for IMAT = 1, NTYPES
+*
+               END DO
+*
+*              END DO for INS = 1, NNS
+*
+            END DO
+*
+*           END DO for IN = 1, NN
+*
+         END DO
+*
+*        END DO for IM = 1, NM
+*
+      END DO
+*
+*     Print a summary of the results.
+*
+      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5,
+     $        ', KMAX =', I5, ', ABSTOL =', G12.5,
+     $        ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4,
+     $        ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
+*
+*     End of ZCHKQP3RK
+*
+      END

lapack-netlib/TESTING/LIN/zlatb4.f

@@ -154,9 +154,6 @@
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, SQRT
 *     ..
-*     .. External Subroutines ..
-      EXTERNAL           DLABAD
-*     ..
 *     .. Save statement ..
       SAVE               EPS, SMALL, LARGE, BADC1, BADC2, FIRST
 *     ..
@@ -174,11 +171,6 @@
          BADC1 = SQRT( BADC2 )
          SMALL = DLAMCH( 'Safe minimum' )
          LARGE = ONE / SMALL
-*
-*        If it looks like we're on a Cray, take the square root of
-*        SMALL and LARGE to avoid overflow and underflow problems.
-*
-         CALL DLABAD( SMALL, LARGE )
          SMALL = SHRINK*( SMALL / EPS )
          LARGE = ONE / SMALL
       END IF
@@ -233,6 +225,110 @@
          ELSE
             ANORM = ONE
          END IF
+*
+      ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN
+*
+*        xQK: truncated QR with pivoting.
+*             Set parameters to generate a general
+*             M x N matrix.
+*
+*        Set TYPE, the type of matrix to be generated.  'N' is nonsymmetric.
+*
+         TYPE = 'N'
+*
+*        Set DIST, the type of distribution for the random
+*        number generator. 'S' is
+*
+         DIST = 'S'
+*
+*        Set the lower and upper bandwidths.
+*
+         IF( IMAT.EQ.2 ) THEN
+*
+*           2. Random, Diagonal, CNDNUM = 2
+*
+            KL = 0
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.3 ) THEN
+*
+*           3. Random, Upper triangular,  CNDNUM = 2
+*
+            KL = 0
+            KU = MAX( N-1, 0 )
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE IF( IMAT.EQ.4 ) THEN
+*
+*          4. Random, Lower triangular,  CNDNUM = 2
+*
+            KL = MAX( M-1, 0 )
+            KU = 0
+            CNDNUM = TWO
+            ANORM = ONE
+            MODE = 3
+         ELSE
+*
+*           5.-19. Rectangular matrix
+*
+            KL = MAX( M-1, 0 )
+            KU = MAX( N-1, 0 )
+*
+            IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN
+*
+*              5.-14. Random, CNDNUM = 2.
+*
+               CNDNUM = TWO
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.15 ) THEN
+*
+*              15. Random, CNDNUM = sqrt(0.1/EPS)
+*
+               CNDNUM = BADC1
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.16 ) THEN
+*
+*              16. Random, CNDNUM = 0.1/EPS
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.17 ) THEN
+*
+*              17. Random, CNDNUM = 0.1/EPS,
+*                  one small singular value S(N)=1/CNDNUM
+*
+               CNDNUM = BADC2
+               ANORM = ONE
+               MODE = 2
+*
+            ELSE IF( IMAT.EQ.18 ) THEN
+*
+*              18. Random, scaled near underflow
+*
+               CNDNUM = TWO
+               ANORM = SMALL
+               MODE = 3
+*
+            ELSE IF( IMAT.EQ.19 ) THEN
+*
+*              19. Random, scaled near overflow
+*
+               CNDNUM = TWO
+               ANORM = LARGE
+               MODE = 3
+*
+            END IF
+*
+         END IF
 *
       ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
 *
@@ -517,17 +613,18 @@
 *
 *        Set the norm and condition number.
 *
-         IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN
+         MAT = ABS( IMAT )
+         IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN
             CNDNUM = BADC1
-         ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN
+         ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN
             CNDNUM = BADC2
          ELSE
             CNDNUM = TWO
          END IF
 *
-         IF( IMAT.EQ.4 ) THEN
+         IF( MAT.EQ.4 ) THEN
             ANORM = SMALL
-         ELSE IF( IMAT.EQ.5 ) THEN
+         ELSE IF( MAT.EQ.5 ) THEN
             ANORM = LARGE
          ELSE
             ANORM = ONE

lapack-netlib/TESTING/LIN/zqpt01.f

@@ -33,7 +33,7 @@
 *> Householder vectors, and the rest of AF contains a partially updated
 *> matrix.
 *>
-*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
+*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) )
 *> \endverbatim
 *
 *  Arguments:
@@ -172,28 +172,28 @@
 *
       NORMA = ZLANGE( 'One-norm', M, N, A, LDA, RWORK )
 *
-      DO 30 J = 1, K
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, K
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = AF( I, J )
-   10    CONTINUE
-         DO 20 I = J + 1, M
+         END DO
+         DO I = J + 1, M
             WORK( ( J-1 )*M+I ) = ZERO
-   20    CONTINUE
-   30 CONTINUE
-      DO 40 J = K + 1, N
+         END DO
+      END DO
+      DO J = K + 1, N
          CALL ZCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 )
-   40 CONTINUE
+      END DO
 *
       CALL ZUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK,
      $             M, WORK( M*N+1 ), LWORK-M*N, INFO )
 *
-      DO 50 J = 1, N
+      DO J = 1, N
 *
 *        Compare i-th column of QR and jpvt(i)-th column of A
 *
          CALL ZAXPY( M, DCMPLX( -ONE ), A( 1, JPVT( J ) ), 1,
      $               WORK( ( J-1 )*M+1 ), 1 )
-   50 CONTINUE
+      END DO
 *
       ZQPT01 = ZLANGE( 'One-norm', M, N, WORK, M, RWORK ) /
      $         ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/zqrt11.f

@@ -158,9 +158,9 @@
       CALL ZUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU,
      $             WORK, M, WORK( M*M+1 ), INFO )
 *
-      DO 10 J = 1, M
+      DO J = 1, M
          WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE
-   10 CONTINUE
+      END DO
 *
       ZQRT11 = ZLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) /
      $         ( DBLE( M )*DLAMCH( 'Epsilon' ) )

lapack-netlib/TESTING/LIN/zqrt12.f

@@ -28,7 +28,7 @@
 *> ZQRT12 computes the singular values `svlues' of the upper trapezoid
 *> of A(1:M,1:N) and returns the ratio
 *>
-*>      || s - svlues||/(||svlues||*eps*max(M,N))
+*>      || svlues - s||/(||s||*eps*max(M,N))
 *> \endverbatim
 *
 *  Arguments:
@@ -125,8 +125,8 @@
       EXTERNAL           DASUM, DLAMCH, DNRM2, ZLANGE
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           DAXPY, DBDSQR, DLABAD, DLASCL, XERBLA, ZGEBD2,
-     $                   ZLASCL, ZLASET
+      EXTERNAL           DAXPY, DBDSQR, DLASCL, XERBLA, ZGEBD2, ZLASCL,
+     $                   ZLASET
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          DBLE, DCMPLX, MAX, MIN
@@ -154,17 +154,16 @@
 *
       CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), DCMPLX( ZERO ), WORK,
      $             M )
-      DO 20 J = 1, N
-         DO 10 I = 1, MIN( J, M )
+      DO J = 1, N
+         DO I = 1, MIN( J, M )
             WORK( ( J-1 )*M+I ) = A( I, J )
-   10    CONTINUE
-   20 CONTINUE
+         END DO
+      END DO
 *
 *     Get machine parameters
 *
       SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
       BIGNUM = ONE / SMLNUM
-      CALL DLABAD( SMLNUM, BIGNUM )
 *
 *     Scale work if max entry outside range [SMLNUM,BIGNUM]
 *
@@ -208,9 +207,9 @@
 *
       ELSE
 *
-         DO 30 I = 1, MN
+         DO I = 1, MN
             RWORK( I ) = ZERO
-   30    CONTINUE
+         END DO
       END IF
 *
 *     Compare s and singular values of work
@@ -218,6 +217,7 @@
       CALL DAXPY( MN, -ONE, S, 1, RWORK( 1 ), 1 )
       ZQRT12 = DASUM( MN, RWORK( 1 ), 1 ) /
      $         ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
+*
       IF( NRMSVL.NE.ZERO )
      $   ZQRT12 = ZQRT12 / NRMSVL
 *

lapack-netlib/TESTING/ctest.in

@@ -42,6 +42,7 @@ CRQ    8               List types on next line if 0 < NTYPES <  8
 CLQ    8               List types on next line if 0 < NTYPES <  8
 CQL    8               List types on next line if 0 < NTYPES <  8
 CQP    6               List types on next line if 0 < NTYPES <  6
+CQK   19               List types on next line if 0 < NTYPES < 19
 CTZ    3               List types on next line if 0 < NTYPES <  3
 CLS    6               List types on next line if 0 < NTYPES <  6
 CEQ

lapack-netlib/TESTING/dtest.in

@@ -36,6 +36,7 @@ DRQ    8               List types on next line if 0 < NTYPES <  8
 DLQ    8               List types on next line if 0 < NTYPES <  8
 DQL    8               List types on next line if 0 < NTYPES <  8
 DQP    6               List types on next line if 0 < NTYPES <  6
+DQK   19               LIst types on next line if 0 < NTYPES < 19
 DTZ    3               List types on next line if 0 < NTYPES <  3
 DLS    6               List types on next line if 0 < NTYPES <  6
 DEQ

lapack-netlib/TESTING/stest.in

@@ -36,6 +36,7 @@ SRQ    8               List types on next line if 0 < NTYPES <  8
 SLQ    8               List types on next line if 0 < NTYPES <  8
 SQL    8               List types on next line if 0 < NTYPES <  8
 SQP    6               List types on next line if 0 < NTYPES <  6
+SQK   19               List types on next line if 0 < NTYPES < 19
 STZ    3               List types on next line if 0 < NTYPES <  3
 SLS    6               List types on next line if 0 < NTYPES <  6
 SEQ

lapack-netlib/TESTING/ztest.in

@@ -42,6 +42,7 @@ ZRQ    8               List types on next line if 0 < NTYPES <  8
 ZLQ    8               List types on next line if 0 < NTYPES <  8
 ZQL    8               List types on next line if 0 < NTYPES <  8
 ZQP    6               List types on next line if 0 < NTYPES <  6
+ZQK   19               List types on next line if 0 < NTYPES < 19
 ZTZ    3               List types on next line if 0 < NTYPES <  3
 ZLS    6               List types on next line if 0 < NTYPES <  6
 ZEQ