Skip to content

Commit

Permalink
Implement truncated QR with pivot (Reference-LAPACK PR 891)
Browse files Browse the repository at this point in the history
  • Loading branch information
@martin-frbg
martin-frbg authored Nov 15, 2023
1 parent 20a2a83 commit 8b2a956
Showing 1 changed file with 63 additions and 20 deletions.
83 changes: 63 additions & 20 deletions lapack-netlib/SRC/ilaenv.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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);}
Expand Down Expand Up @@ -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++ */

Expand Down Expand Up @@ -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 */
Expand Down Expand Up @@ -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 */
Expand Down Expand Up @@ -652,9 +658,7 @@ f"> */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */

/* > \date November 2019 */

/* > \ingroup OTHERauxiliary */
/* > \ingroup ilaenv */

/* > \par Further Details: */
/* ===================== */
Expand Down Expand Up @@ -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;
Expand All @@ -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 */


/* ===================================================================== */
Expand All @@ -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 */
Expand Down Expand Up @@ -908,6 +912,12 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
} 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) {
Expand Down Expand Up @@ -1034,6 +1044,21 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
} 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) {
Expand All @@ -1042,6 +1067,12 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
} 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) {
Expand Down Expand Up @@ -1093,6 +1124,12 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
} 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) {
Expand Down Expand Up @@ -1184,6 +1221,12 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
} 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) {
Expand Down Expand Up @@ -1270,29 +1313,29 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,

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)
;
Expand Down

0 comments on commit 8b2a956

Please sign in to comment.