floraachy
/
OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #4322 from martin-frbg/lapack891 

Add truncated QR with pivoting (Reference-LAPACK PR 891)
This commit is contained in:
Martin Kroeker 2023-11-16 08:40:17 +01:00 committed by GitHub
parent ee47e4e494 cc622f2406
commit cb2950709f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
64 changed files with 27755 additions and 287 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
cmake/lapack.cmake
View File

@ -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

16
lapack-netlib/SRC/Makefile
View File

@ -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 \

1071
lapack-netlib/SRC/cgeqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

1091
lapack-netlib/SRC/cgeqp3rk.f Normal file
View File

File diff suppressed because it is too large Load Diff

943
lapack-netlib/SRC/claqp2rk.c Normal file
View File

@ -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_ */

726
lapack-netlib/SRC/claqp2rk.f Normal file
View File

@ -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

1152
lapack-netlib/SRC/claqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

947
lapack-netlib/SRC/claqp3rk.f Normal file
View File

@ -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

1059
lapack-netlib/SRC/dgeqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

1081
lapack-netlib/SRC/dgeqp3rk.f Normal file
View File

File diff suppressed because it is too large Load Diff

923
lapack-netlib/SRC/dlaqp2rk.c Normal file
View File

@ -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_ */

713
lapack-netlib/SRC/dlaqp2rk.f Normal file
View File

@ -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

1113
lapack-netlib/SRC/dlaqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

935
lapack-netlib/SRC/dlaqp3rk.f Normal file
View File

@ -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

83
lapack-netlib/SRC/ilaenv.c
View File

@ -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)
;

21
lapack-netlib/SRC/ilaenv.f
View File

@ -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

1055
lapack-netlib/SRC/sgeqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

1081
lapack-netlib/SRC/sgeqp3rk.f Normal file
View File

File diff suppressed because it is too large Load Diff

918
lapack-netlib/SRC/slaqp2rk.c Normal file
View File

@ -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_ */

713
lapack-netlib/SRC/slaqp2rk.f Normal file
View File

@ -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

1109
lapack-netlib/SRC/slaqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

935
lapack-netlib/SRC/slaqp3rk.f Normal file
View File

@ -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

1074
lapack-netlib/SRC/zgeqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

1091
lapack-netlib/SRC/zgeqp3rk.f Normal file
View File

File diff suppressed because it is too large Load Diff

947
lapack-netlib/SRC/zlaqp2rk.c Normal file
View File

@ -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_ */

726
lapack-netlib/SRC/zlaqp2rk.f Normal file
View File

@ -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

1157
lapack-netlib/SRC/zlaqp3rk.c Normal file
View File

File diff suppressed because it is too large Load Diff

947
lapack-netlib/SRC/zlaqp3rk.f Normal file
View File

@ -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

6
lapack-netlib/TESTING/EIG/alareq.f
View File

@ -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:

6
lapack-netlib/TESTING/EIG/alarqg.f
View File

@ -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:

8
lapack-netlib/TESTING/LIN/CMakeLists.txt
View File

@ -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

48
lapack-netlib/TESTING/LIN/Makefile
View File

@ -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)

17
lapack-netlib/TESTING/LIN/alaerh.f
View File

@ -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
*

62
lapack-netlib/TESTING/LIN/alahd.f
View File

@ -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
*

6
lapack-netlib/TESTING/LIN/alareq.f
View File

@ -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:

43
lapack-netlib/TESTING/LIN/cchkaa.F
View File

@ -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
*

836
lapack-netlib/TESTING/LIN/cchkqp3rk.f Normal file
View File

@ -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

121
lapack-netlib/TESTING/LIN/clatb4.f
View File

@ -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

23
lapack-netlib/TESTING/LIN/cqpt01.f
View File

@ -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' ) )

4
lapack-netlib/TESTING/LIN/cqrt11.f
View File

@ -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' ) )

19
lapack-netlib/TESTING/LIN/cqrt12.f
View File

@ -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

48
lapack-netlib/TESTING/LIN/dchkaa.F
View File

@ -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

2
lapack-netlib/TESTING/LIN/dchkq3.f
View File

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

832
lapack-netlib/TESTING/LIN/dchkqp3rk.f Normal file
View File

@ -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

123
lapack-netlib/TESTING/LIN/dlatb4.f
View File

@ -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

42
lapack-netlib/TESTING/LIN/dqpt01.f
View File

@ -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' ) )

4
lapack-netlib/TESTING/LIN/dqrt11.f
View File

@ -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' ) )

22
lapack-netlib/TESTING/LIN/dqrt12.f
View File

@ -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
*

48
lapack-netlib/TESTING/LIN/schkaa.F
View File

@ -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
*

831
lapack-netlib/TESTING/LIN/schkqp3rk.f Normal file
View File

@ -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

121
lapack-netlib/TESTING/LIN/slatb4.f
View File

@ -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

23
lapack-netlib/TESTING/LIN/sqpt01.f
View File

@ -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' ) )

4
lapack-netlib/TESTING/LIN/sqrt11.f
View File

@ -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' ) )

18
lapack-netlib/TESTING/LIN/sqrt12.f
View File

@ -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

59
lapack-netlib/TESTING/LIN/zchkaa.F
View File

@ -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 (A ((KDMAX+1) * NMAX, 7), STAT = AllocateStatus)
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 (B (NMAX * MAXRHS, 4), STAT = AllocateStatus)
ALLOCATE ( E( NMAX ), STAT = AllocateStatus )
IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"
ALLOCATE (WORK (NMAX, NMAX+MAXRHS+10), STAT = AllocateStatus)
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 ***"
* ..
* .. 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
*

836
lapack-netlib/TESTING/LIN/zchkqp3rk.f Normal file
View File

@ -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

121
lapack-netlib/TESTING/LIN/zlatb4.f
View File

@ -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

22
lapack-netlib/TESTING/LIN/zqpt01.f
View File

@ -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' ) )

4
lapack-netlib/TESTING/LIN/zqrt11.f
View File

@ -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' ) )

20
lapack-netlib/TESTING/LIN/zqrt12.f
View File

@ -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
*

1
lapack-netlib/TESTING/ctest.in
View File

@ -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

1
lapack-netlib/TESTING/dtest.in
View File

@ -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

1
lapack-netlib/TESTING/stest.in
View File

@ -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

1
lapack-netlib/TESTING/ztest.in
View File

@ -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