ICODE-ADC/lammps
4
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

whitespace fixes

Browse Source
This commit is contained in:
Axel Kohlmeyer
2022-12-28 13:47:11 -05:00
parent a894cbfbb7
commit 1e8b2ad5a0
194 changed files with 24511 additions and 24511 deletions
Download Patch File Download Diff File Expand all files Collapse all files

68
lib/linalg/dasum.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dasum.f -- translated by f2c (version 20200916). /* fortran/dasum.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -118,7 +118,7 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx)
ret_val = 0.; ret_val = 0.;
dtemp = 0.; dtemp = 0.;
if (*n <= 0 || *incx <= 0) { if (*n <= 0 || *incx <= 0) {
return ret_val; return ret_val;
} }
if (*incx == 1) { if (*incx == 1) {
/* code for increment equal to 1 */ /* code for increment equal to 1 */
@ -126,35 +126,35 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx)
/* clean-up loop */ /* clean-up loop */
m = *n % 6; m = *n % 6;
if (m != 0) { if (m != 0) {
i__1 = m; i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dtemp += (d__1 = dx[i__], abs(d__1)); dtemp += (d__1 = dx[i__], abs(d__1));
} }
if (*n < 6) { if (*n < 6) {
ret_val = dtemp; ret_val = dtemp;
return ret_val; return ret_val;
} }
} }
mp1 = m + 1; mp1 = m + 1;
i__1 = *n; i__1 = *n;
for (i__ = mp1; i__ <= i__1; i__ += 6) { for (i__ = mp1; i__ <= i__1; i__ += 6) {
dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1],
abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 =
dx[i__ + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) dx[i__ + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5))
+ (d__6 = dx[i__ + 5], abs(d__6)); + (d__6 = dx[i__ + 5], abs(d__6));
} }
} else { } else {
/* code for increment not equal to 1 */ /* code for increment not equal to 1 */
nincx = *n * *incx; nincx = *n * *incx;
i__1 = nincx; i__1 = nincx;
i__2 = *incx; i__2 = *incx;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
dtemp += (d__1 = dx[i__], abs(d__1)); dtemp += (d__1 = dx[i__], abs(d__1));
} }
} }
ret_val = dtemp; ret_val = dtemp;
return ret_val; return ret_val;
@ -164,5 +164,5 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx)
} /* dasum_ */ } /* dasum_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

88
lib/linalg/daxpy.cpp
View File

@ -1,13 +1,13 @@
/* fortran/daxpy.f -- translated by f2c (version 20200916). /* fortran/daxpy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -102,8 +102,8 @@ extern "C" {
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, /* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx,
integer *incx, doublereal *dy, integer *incy) integer *incx, doublereal *dy, integer *incy)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -133,10 +133,10 @@ extern "C" {
/* Function Body */ /* Function Body */
if (*n <= 0) { if (*n <= 0) {
return 0; return 0;
} }
if (*da == 0.) { if (*da == 0.) {
return 0; return 0;
} }
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
@ -145,43 +145,43 @@ extern "C" {
/* clean-up loop */ /* clean-up loop */
m = *n % 4; m = *n % 4;
if (m != 0) { if (m != 0) {
i__1 = m; i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dy[i__] += *da * dx[i__]; dy[i__] += *da * dx[i__];
} }
} }
if (*n < 4) { if (*n < 4) {
return 0; return 0;
} }
mp1 = m + 1; mp1 = m + 1;
i__1 = *n; i__1 = *n;
for (i__ = mp1; i__ <= i__1; i__ += 4) { for (i__ = mp1; i__ <= i__1; i__ += 4) {
dy[i__] += *da * dx[i__]; dy[i__] += *da * dx[i__];
dy[i__ + 1] += *da * dx[i__ + 1]; dy[i__ + 1] += *da * dx[i__ + 1];
dy[i__ + 2] += *da * dx[i__ + 2]; dy[i__ + 2] += *da * dx[i__ + 2];
dy[i__ + 3] += *da * dx[i__ + 3]; dy[i__ + 3] += *da * dx[i__ + 3];
} }
} else { } else {
/* code for unequal increments or equal increments */ /* code for unequal increments or equal increments */
/* not equal to 1 */ /* not equal to 1 */
ix = 1; ix = 1;
iy = 1; iy = 1;
if (*incx < 0) { if (*incx < 0) {
ix = (-(*n) + 1) * *incx + 1; ix = (-(*n) + 1) * *incx + 1;
} }
if (*incy < 0) { if (*incy < 0) {
iy = (-(*n) + 1) * *incy + 1; iy = (-(*n) + 1) * *incy + 1;
} }
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dy[iy] += *da * dx[ix]; dy[iy] += *da * dx[ix];
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
} }
} }
return 0; return 0;
@ -190,5 +190,5 @@ extern "C" {
} /* daxpy_ */ } /* daxpy_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

796
lib/linalg/dbdsqr.cpp
View File

File diff suppressed because it is too large Load Diff

16
lib/linalg/dcabs1.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dcabs1.f -- translated by f2c (version 20200916). /* fortran/dcabs1.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -88,5 +88,5 @@ doublereal dcabs1_(doublecomplex *z__)
} /* dcabs1_ */ } /* dcabs1_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

92
lib/linalg/dcopy.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dcopy.f -- translated by f2c (version 20200916). /* fortran/dcopy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -95,8 +95,8 @@ extern "C" {
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, /* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx,
doublereal *dy, integer *incy) doublereal *dy, integer *incy)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -126,7 +126,7 @@ extern "C" {
/* Function Body */ /* Function Body */
if (*n <= 0) { if (*n <= 0) {
return 0; return 0;
} }
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
@ -135,46 +135,46 @@ extern "C" {
/* clean-up loop */ /* clean-up loop */
m = *n % 7; m = *n % 7;
if (m != 0) { if (m != 0) {
i__1 = m; i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dy[i__] = dx[i__]; dy[i__] = dx[i__];
} }
if (*n < 7) { if (*n < 7) {
return 0; return 0;
} }
} }
mp1 = m + 1; mp1 = m + 1;
i__1 = *n; i__1 = *n;
for (i__ = mp1; i__ <= i__1; i__ += 7) { for (i__ = mp1; i__ <= i__1; i__ += 7) {
dy[i__] = dx[i__]; dy[i__] = dx[i__];
dy[i__ + 1] = dx[i__ + 1]; dy[i__ + 1] = dx[i__ + 1];
dy[i__ + 2] = dx[i__ + 2]; dy[i__ + 2] = dx[i__ + 2];
dy[i__ + 3] = dx[i__ + 3]; dy[i__ + 3] = dx[i__ + 3];
dy[i__ + 4] = dx[i__ + 4]; dy[i__ + 4] = dx[i__ + 4];
dy[i__ + 5] = dx[i__ + 5]; dy[i__ + 5] = dx[i__ + 5];
dy[i__ + 6] = dx[i__ + 6]; dy[i__ + 6] = dx[i__ + 6];
} }
} else { } else {
/* code for unequal increments or equal increments */ /* code for unequal increments or equal increments */
/* not equal to 1 */ /* not equal to 1 */
ix = 1; ix = 1;
iy = 1; iy = 1;
if (*incx < 0) { if (*incx < 0) {
ix = (-(*n) + 1) * *incx + 1; ix = (-(*n) + 1) * *incx + 1;
} }
if (*incy < 0) { if (*incy < 0) {
iy = (-(*n) + 1) * *incy + 1; iy = (-(*n) + 1) * *incy + 1;
} }
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dy[iy] = dx[ix]; dy[iy] = dx[ix];
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
} }
} }
return 0; return 0;
@ -183,5 +183,5 @@ extern "C" {
} /* dcopy_ */ } /* dcopy_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

86
lib/linalg/ddot.cpp
View File

@ -1,13 +1,13 @@
/* fortran/ddot.f -- translated by f2c (version 20200916). /* fortran/ddot.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -95,8 +95,8 @@ extern "C" {
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
integer *incy) integer *incy)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -130,7 +130,7 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
ret_val = 0.; ret_val = 0.;
dtemp = 0.; dtemp = 0.;
if (*n <= 0) { if (*n <= 0) {
return ret_val; return ret_val;
} }
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
@ -139,43 +139,43 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
/* clean-up loop */ /* clean-up loop */
m = *n % 5; m = *n % 5;
if (m != 0) { if (m != 0) {
i__1 = m; i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dtemp += dx[i__] * dy[i__]; dtemp += dx[i__] * dy[i__];
} }
if (*n < 5) { if (*n < 5) {
ret_val = dtemp; ret_val = dtemp;
return ret_val; return ret_val;
} }
} }
mp1 = m + 1; mp1 = m + 1;
i__1 = *n; i__1 = *n;
for (i__ = mp1; i__ <= i__1; i__ += 5) { for (i__ = mp1; i__ <= i__1; i__ += 5) {
dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] +
dx[i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] +
dx[i__ + 4] * dy[i__ + 4]; dx[i__ + 4] * dy[i__ + 4];
} }
} else { } else {
/* code for unequal increments or equal increments */ /* code for unequal increments or equal increments */
/* not equal to 1 */ /* not equal to 1 */
ix = 1; ix = 1;
iy = 1; iy = 1;
if (*incx < 0) { if (*incx < 0) {
ix = (-(*n) + 1) * *incx + 1; ix = (-(*n) + 1) * *incx + 1;
} }
if (*incy < 0) { if (*incy < 0) {
iy = (-(*n) + 1) * *incy + 1; iy = (-(*n) + 1) * *incy + 1;
} }
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dtemp += dx[ix] * dy[iy]; dtemp += dx[ix] * dy[iy];
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
} }
} }
ret_val = dtemp; ret_val = dtemp;
return ret_val; return ret_val;
@ -185,5 +185,5 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
} /* ddot_ */ } /* ddot_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

174
lib/linalg/dgebd2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgebd2.f -- translated by f2c (version 20200916). /* fortran/dgebd2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -210,19 +210,19 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
taup, doublereal *work, integer *info) taup, doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */ /* Local variables */
integer i__; integer i__;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *, extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *, doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen); ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -261,126 +261,126 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} }
if (*info < 0) { if (*info < 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGEBD2", &i__1, (ftnlen)6); xerbla_((char *)"DGEBD2", &i__1, (ftnlen)6);
return 0; return 0;
} }
if (*m >= *n) { if (*m >= *n) {
/* Reduce to upper bidiagonal form */ /* Reduce to upper bidiagonal form */
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ /* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 1; i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ *
a_dim1], &c__1, &tauq[i__]); a_dim1], &c__1, &tauq[i__]);
d__[i__] = a[i__ + i__ * a_dim1]; d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
/* Apply H(i) to A(i:m,i+1:n) from the left */ /* Apply H(i) to A(i:m,i+1:n) from the left */
if (i__ < *n) { if (i__ < *n) {
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = *n - i__; i__3 = *n - i__;
dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1] tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]
, (ftnlen)4); , (ftnlen)4);
} }
a[i__ + i__ * a_dim1] = d__[i__]; a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *n) { if (i__ < *n) {
/* Generate elementary reflector G(i) to annihilate */ /* Generate elementary reflector G(i) to annihilate */
/* A(i,i+2:n) */ /* A(i,i+2:n) */
i__2 = *n - i__; i__2 = *n - i__;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 2; i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min( dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
i__3,*n) * a_dim1], lda, &taup[i__]); i__3,*n) * a_dim1], lda, &taup[i__]);
e[i__] = a[i__ + (i__ + 1) * a_dim1]; e[i__] = a[i__ + (i__ + 1) * a_dim1];
a[i__ + (i__ + 1) * a_dim1] = 1.; a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */ /* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__; i__2 = *m - i__;
i__3 = *n - i__; i__3 = *n - i__;
dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1], (ftnlen)5); lda, &work[1], (ftnlen)5);
a[i__ + (i__ + 1) * a_dim1] = e[i__]; a[i__ + (i__ + 1) * a_dim1] = e[i__];
} else { } else {
taup[i__] = 0.; taup[i__] = 0.;
} }
/* L10: */ /* L10: */
} }
} else { } else {
/* Reduce to lower bidiagonal form */ /* Reduce to lower bidiagonal form */
i__1 = *m; i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */ /* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 1; i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) *
a_dim1], lda, &taup[i__]); a_dim1], lda, &taup[i__]);
d__[i__] = a[i__ + i__ * a_dim1]; d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
/* Apply G(i) to A(i+1:m,i:n) from the right */ /* Apply G(i) to A(i+1:m,i:n) from the right */
if (i__ < *m) { if (i__ < *m) {
i__2 = *m - i__; i__2 = *m - i__;
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, & dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1],
(ftnlen)5); (ftnlen)5);
} }
a[i__ + i__ * a_dim1] = d__[i__]; a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *m) { if (i__ < *m) {
/* Generate elementary reflector H(i) to annihilate */ /* Generate elementary reflector H(i) to annihilate */
/* A(i+2:m,i) */ /* A(i+2:m,i) */
i__2 = *m - i__; i__2 = *m - i__;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 2; i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) +
i__ * a_dim1], &c__1, &tauq[i__]); i__ * a_dim1], &c__1, &tauq[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1]; e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.; a[i__ + 1 + i__ * a_dim1] = 1.;
/* Apply H(i) to A(i+1:m,i+1:n) from the left */ /* Apply H(i) to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__; i__2 = *m - i__;
i__3 = *n - i__; i__3 = *n - i__;
dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], & dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1], (ftnlen)4); lda, &work[1], (ftnlen)4);
a[i__ + 1 + i__ * a_dim1] = e[i__]; a[i__ + 1 + i__ * a_dim1] = e[i__];
} else { } else {
tauq[i__] = 0.; tauq[i__] = 0.;
} }
/* L20: */ /* L20: */
} }
} }
return 0; return 0;
@ -389,5 +389,5 @@ f"> */
} /* dgebd2_ */ } /* dgebd2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

166
lib/linalg/dgebrd.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgebrd.f -- translated by f2c (version 20200916). /* fortran/dgebrd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -230,26 +230,26 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
taup, doublereal *work, integer *lwork, integer *info) taup, doublereal *work, integer *lwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4; integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, j, nb, nx, ws; integer i__, j, nb, nx, ws;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
integer nbmin, iinfo, minmn; integer nbmin, iinfo, minmn;
extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *, extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlabrd_(integer *, integer *, integer * doublereal *, integer *), dlabrd_(integer *, integer *, integer *
, doublereal *, integer *, doublereal *, doublereal *, doublereal , doublereal *, integer *, doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *, integer *, doublereal *, integer *) *, doublereal *, doublereal *, integer *, doublereal *, integer *)
, xerbla_(char *, integer *, ftnlen); , xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer ldwrkx, ldwrky, lwkopt; integer ldwrkx, ldwrky, lwkopt;
logical lquery; logical lquery;
@ -293,38 +293,38 @@ f"> */
*info = 0; *info = 0;
/* Computing MAX */ /* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( i__1 = 1, i__2 = ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2); nb = max(i__1,i__2);
lwkopt = (*m + *n) * nb; lwkopt = (*m + *n) * nb;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
lquery = *lwork == -1; lquery = *lwork == -1;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} else /* if(complicated condition) */ { } else /* if(complicated condition) */ {
/* Computing MAX */ /* Computing MAX */
i__1 = max(1,*m); i__1 = max(1,*m);
if (*lwork < max(i__1,*n) && ! lquery) { if (*lwork < max(i__1,*n) && ! lquery) {
*info = -10; *info = -10;
} }
} }
if (*info < 0) { if (*info < 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGEBRD", &i__1, (ftnlen)6); xerbla_((char *)"DGEBRD", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
minmn = min(*m,*n); minmn = min(*m,*n);
if (minmn == 0) { if (minmn == 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
ws = max(*m,*n); ws = max(*m,*n);
@ -336,31 +336,31 @@ f"> */
/* Set the crossover point NX. */ /* Set the crossover point NX. */
/* Computing MAX */ /* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2); nx = max(i__1,i__2);
/* Determine when to switch from blocked to unblocked code. */ /* Determine when to switch from blocked to unblocked code. */
if (nx < minmn) { if (nx < minmn) {
ws = (*m + *n) * nb; ws = (*m + *n) * nb;
if (*lwork < ws) { if (*lwork < ws) {
/* Not enough work space for the optimal NB, consider using */ /* Not enough work space for the optimal NB, consider using */
/* a smaller block size. */ /* a smaller block size. */
nbmin = ilaenv_(&c__2, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( nbmin = ilaenv_(&c__2, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
if (*lwork >= (*m + *n) * nbmin) { if (*lwork >= (*m + *n) * nbmin) {
nb = *lwork / (*m + *n); nb = *lwork / (*m + *n);
} else { } else {
nb = 1; nb = 1;
nx = minmn; nx = minmn;
} }
} }
} }
} else { } else {
nx = minmn; nx = minmn;
} }
i__1 = minmn - nx; i__1 = minmn - nx;
@ -371,45 +371,45 @@ f"> */
/* the matrices X and Y which are needed to update the unreduced */ /* the matrices X and Y which are needed to update the unreduced */
/* part of the matrix */ /* part of the matrix */
i__3 = *m - i__ + 1; i__3 = *m - i__ + 1;
i__4 = *n - i__ + 1; i__4 = *n - i__ + 1;
dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[ dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx
* nb + 1], &ldwrky); * nb + 1], &ldwrky);
/* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */ /* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */
/* of the form A := A - V*Y**T - X*U**T */ /* of the form A := A - V*Y**T - X*U**T */
i__3 = *m - i__ - nb + 1; i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1; i__4 = *n - i__ - nb + 1;
dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__ dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__
+ nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], & + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], &
ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, ( ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, (
ftnlen)12, (ftnlen)9); ftnlen)12, (ftnlen)9);
i__3 = *m - i__ - nb + 1; i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1; i__4 = *n - i__ - nb + 1;
dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &nb, &c_b21, & dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &nb, &c_b21, &
work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, & work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)12, ( c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)12, (
ftnlen)12); ftnlen)12);
/* Copy diagonal and off-diagonal elements of B back into A */ /* Copy diagonal and off-diagonal elements of B back into A */
if (*m >= *n) { if (*m >= *n) {
i__3 = i__ + nb - 1; i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) { for (j = i__; j <= i__3; ++j) {
a[j + j * a_dim1] = d__[j]; a[j + j * a_dim1] = d__[j];
a[j + (j + 1) * a_dim1] = e[j]; a[j + (j + 1) * a_dim1] = e[j];
/* L10: */ /* L10: */
} }
} else { } else {
i__3 = i__ + nb - 1; i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) { for (j = i__; j <= i__3; ++j) {
a[j + j * a_dim1] = d__[j]; a[j + j * a_dim1] = d__[j];
a[j + 1 + j * a_dim1] = e[j]; a[j + 1 + j * a_dim1] = e[j];
/* L20: */ /* L20: */
} }
} }
/* L30: */ /* L30: */
} }
@ -418,7 +418,7 @@ f"> */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1; i__1 = *n - i__ + 1;
dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], & dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
tauq[i__], &taup[i__], &work[1], &iinfo); tauq[i__], &taup[i__], &work[1], &iinfo);
work[1] = (doublereal) ws; work[1] = (doublereal) ws;
return 0; return 0;
@ -427,5 +427,5 @@ f"> */
} /* dgebrd_ */ } /* dgebrd_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

112
lib/linalg/dgecon.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgecon.f -- translated by f2c (version 20200916). /* fortran/dgecon.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -144,8 +144,8 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer * /* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer *
lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer * lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *
iwork, integer *info, ftnlen norm_len) iwork, integer *info, ftnlen norm_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1; integer a_dim1, a_offset, i__1;
@ -159,16 +159,16 @@ f"> */
doublereal scale; doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer isave[3]; integer isave[3];
extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
integer *), dlacn2_(integer *, doublereal *, doublereal *, integer *), dlacn2_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *); integer *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
doublereal ainvnm; doublereal ainvnm;
extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *, extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
logical onenrm; logical onenrm;
char normin[1]; char normin[1];
doublereal smlnum; doublereal smlnum;
@ -211,30 +211,30 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, (char *)"O", (ftnlen)1, ( onenrm = *(unsigned char *)norm == '1' || lsame_(norm, (char *)"O", (ftnlen)1, (
ftnlen)1); ftnlen)1);
if (! onenrm && ! lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { if (! onenrm && ! lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*n)) { } else if (*lda < max(1,*n)) {
*info = -4; *info = -4;
} else if (*anorm < 0.) { } else if (*anorm < 0.) {
*info = -5; *info = -5;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGECON", &i__1, (ftnlen)6); xerbla_((char *)"DGECON", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
*rcond = 0.; *rcond = 0.;
if (*n == 0) { if (*n == 0) {
*rcond = 1.; *rcond = 1.;
return 0; return 0;
} else if (*anorm == 0.) { } else if (*anorm == 0.) {
return 0; return 0;
} }
smlnum = dlamch_((char *)"Safe minimum", (ftnlen)12); smlnum = dlamch_((char *)"Safe minimum", (ftnlen)12);
@ -244,61 +244,61 @@ f"> */
ainvnm = 0.; ainvnm = 0.;
*(unsigned char *)normin = 'N'; *(unsigned char *)normin = 'N';
if (onenrm) { if (onenrm) {
kase1 = 1; kase1 = 1;
} else { } else {
kase1 = 2; kase1 = 2;
} }
kase = 0; kase = 0;
L10: L10:
dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0) { if (kase != 0) {
if (kase == kase1) { if (kase == kase1) {
/* Multiply by inv(L). */ /* Multiply by inv(L). */
dlatrs_((char *)"Lower", (char *)"No transpose", (char *)"Unit", normin, n, &a[a_offset], dlatrs_((char *)"Lower", (char *)"No transpose", (char *)"Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5,
(ftnlen)12, (ftnlen)4, (ftnlen)1); (ftnlen)12, (ftnlen)4, (ftnlen)1);
/* Multiply by inv(U). */ /* Multiply by inv(U). */
dlatrs_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", normin, n, &a[ dlatrs_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info, ( a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else { } else {
/* Multiply by inv(U**T). */ /* Multiply by inv(U**T). */
dlatrs_((char *)"Upper", (char *)"Transpose", (char *)"Non-unit", normin, n, &a[a_offset], dlatrs_((char *)"Upper", (char *)"Transpose", (char *)"Non-unit", normin, n, &a[a_offset],
lda, &work[1], &su, &work[*n * 3 + 1], info, (ftnlen)5, ( lda, &work[1], &su, &work[*n * 3 + 1], info, (ftnlen)5, (
ftnlen)9, (ftnlen)8, (ftnlen)1); ftnlen)9, (ftnlen)8, (ftnlen)1);
/* Multiply by inv(L**T). */ /* Multiply by inv(L**T). */
dlatrs_((char *)"Lower", (char *)"Transpose", (char *)"Unit", normin, n, &a[a_offset], dlatrs_((char *)"Lower", (char *)"Transpose", (char *)"Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5,
(ftnlen)9, (ftnlen)4, (ftnlen)1); (ftnlen)9, (ftnlen)4, (ftnlen)1);
} }
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ /* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su; scale = sl * su;
*(unsigned char *)normin = 'Y'; *(unsigned char *)normin = 'Y';
if (scale != 1.) { if (scale != 1.) {
ix = idamax_(n, &work[1], &c__1); ix = idamax_(n, &work[1], &c__1);
if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
{ {
goto L20; goto L20;
} }
drscl_(n, &scale, &work[1], &c__1); drscl_(n, &scale, &work[1], &c__1);
} }
goto L10; goto L10;
} }
/* Compute the estimate of the reciprocal condition number. */ /* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) { if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm; *rcond = 1. / ainvnm / *anorm;
} }
L20: L20:
@ -309,5 +309,5 @@ L20:
} /* dgecon_ */ } /* dgecon_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

68
lib/linalg/dgelq2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgelq2.f -- translated by f2c (version 20200916). /* fortran/dgelq2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -147,7 +147,7 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info) lda, doublereal *tau, doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -155,11 +155,11 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, k; integer i__, k;
doublereal aii; doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *, extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *, doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen); ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -195,16 +195,16 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGELQ2", &i__1, (ftnlen)6); xerbla_((char *)"DGELQ2", &i__1, (ftnlen)6);
return 0; return 0;
} }
k = min(*m,*n); k = min(*m,*n);
@ -214,24 +214,24 @@ f"> */
/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */ /* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 1; i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * a_dim1] dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * a_dim1]
, lda, &tau[i__]); , lda, &tau[i__]);
if (i__ < *m) { if (i__ < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */ /* Apply H(i) to A(i+1:m,i:n) from the right */
aii = a[i__ + i__ * a_dim1]; aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
i__2 = *m - i__; i__2 = *m - i__;
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen) i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)
5); 5);
a[i__ + i__ * a_dim1] = aii; a[i__ + i__ * a_dim1] = aii;
} }
/* L10: */ /* L10: */
} }
return 0; return 0;
@ -241,5 +241,5 @@ f"> */
} /* dgelq2_ */ } /* dgelq2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

140
lib/linalg/dgelqf.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgelqf.f -- translated by f2c (version 20200916). /* fortran/dgelqf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -167,23 +167,23 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4; integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, k, ib, nb, nx, iws, nbmin, iinfo; integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *, extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
char *, char *, char *, integer *, integer *, integer *, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen, *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer ldwork, lwkopt; integer ldwork, lwkopt;
logical lquery; logical lquery;
@ -221,33 +221,33 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
nb = ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) nb = ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1); 1);
lwkopt = *m * nb; lwkopt = *m * nb;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
lquery = *lwork == -1; lquery = *lwork == -1;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} else if (*lwork < max(1,*m) && ! lquery) { } else if (*lwork < max(1,*m) && ! lquery) {
*info = -7; *info = -7;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGELQF", &i__1, (ftnlen)6); xerbla_((char *)"DGELQF", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
k = min(*m,*n); k = min(*m,*n);
if (k == 0) { if (k == 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
@ -258,79 +258,79 @@ f"> */
/* Determine when to cross over from blocked to unblocked code. */ /* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */ /* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, ( i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2); nx = max(i__1,i__2);
if (nx < k) { if (nx < k) {
/* Determine if workspace is large enough for blocked code. */ /* Determine if workspace is large enough for blocked code. */
ldwork = *m; ldwork = *m;
iws = ldwork * nb; iws = ldwork * nb;
if (*lwork < iws) { if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */ /* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */ /* determine the minimum value of NB. */
nb = *lwork / ldwork; nb = *lwork / ldwork;
/* Computing MAX */ /* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGELQF", (char *)" ", m, n, &c_n1, & i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1); c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
} }
if (nb >= nbmin && nb < k && nx < k) { if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */ /* Use blocked code initially */
i__1 = k - nx; i__1 = k - nx;
i__2 = nb; i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */ /* Computing MIN */
i__3 = k - i__ + 1; i__3 = k - i__ + 1;
ib = min(i__3,nb); ib = min(i__3,nb);
/* Compute the LQ factorization of the current block */ /* Compute the LQ factorization of the current block */
/* A(i:i+ib-1,i:n) */ /* A(i:i+ib-1,i:n) */
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo); 1], &iinfo);
if (i__ + ib <= *m) { if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */ /* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dlarft_((char *)"Forward", (char *)"Rowwise", &i__3, &ib, &a[i__ + i__ * dlarft_((char *)"Forward", (char *)"Rowwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)7); (ftnlen)7);
/* Apply H to A(i+ib:m,i:n) from the right */ /* Apply H to A(i+ib:m,i:n) from the right */
i__3 = *m - i__ - ib + 1; i__3 = *m - i__ - ib + 1;
i__4 = *n - i__ + 1; i__4 = *n - i__ + 1;
dlarfb_((char *)"Right", (char *)"No transpose", (char *)"Forward", (char *)"Rowwise", &i__3, dlarfb_((char *)"Right", (char *)"No transpose", (char *)"Forward", (char *)"Rowwise", &i__3,
&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
1], &ldwork, (ftnlen)5, (ftnlen)12, (ftnlen)7, ( 1], &ldwork, (ftnlen)5, (ftnlen)12, (ftnlen)7, (
ftnlen)7); ftnlen)7);
} }
/* L10: */ /* L10: */
} }
} else { } else {
i__ = 1; i__ = 1;
} }
/* Use unblocked code to factor the last or only block. */ /* Use unblocked code to factor the last or only block. */
if (i__ <= k) { if (i__ <= k) {
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1; i__1 = *n - i__ + 1;
dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo); , &iinfo);
} }
work[1] = (doublereal) iws; work[1] = (doublereal) iws;
@ -341,5 +341,5 @@ f"> */
} /* dgelqf_ */ } /* dgelqf_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

586
lib/linalg/dgelsd.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgelsd.f -- translated by f2c (version 20200916). /* fortran/dgelsd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -234,10 +234,10 @@ f"> */
/* > Osni Marques, LBNL/NERSC, USA \n */ /* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs, /* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
integer *iwork, integer *info) integer *iwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
@ -252,39 +252,39 @@ f"> */
doublereal sfmin; doublereal sfmin;
integer minmn, maxmn, itaup, itauq, mnthr, nwork; integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_( extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_(
integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *); integer *);
extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, ftnlen); integer *, doublereal *, integer *, doublereal *, ftnlen);
extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *), integer *, doublereal *, doublereal *, integer *, integer *),
dlalsd_(char *, integer *, integer *, integer *, doublereal *, dlalsd_(char *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, ftnlen), dlascl_(char *, doublereal *, integer *, integer *, ftnlen), dlascl_(char *,
integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, ftnlen), dgeqrf_( integer *, doublereal *, integer *, integer *, ftnlen), dgeqrf_(
integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *), dlacpy_(char *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), dlaset_(char *, integer *, integer *, doublereal *, ftnlen), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, ftnlen), xerbla_(char *, doublereal *, doublereal *, integer *, ftnlen), xerbla_(char *,
integer *, ftnlen); integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
doublereal bignum; doublereal bignum;
extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen, ftnlen, ftnlen); ftnlen, ftnlen, ftnlen);
integer wlalsd; integer wlalsd;
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
integer ldwork; integer ldwork;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
integer liwork, minwrk, maxwrk; integer liwork, minwrk, maxwrk;
doublereal smlnum; doublereal smlnum;
logical lquery; logical lquery;
@ -332,22 +332,22 @@ f"> */
minmn = min(*m,*n); minmn = min(*m,*n);
maxmn = max(*m,*n); maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, (char *)"DGELSD", (char *)" ", m, n, nrhs, &c_n1, (ftnlen)6, ( mnthr = ilaenv_(&c__6, (char *)"DGELSD", (char *)" ", m, n, nrhs, &c_n1, (ftnlen)6, (
ftnlen)1); ftnlen)1);
lquery = *lwork == -1; lquery = *lwork == -1;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*nrhs < 0) { } else if (*nrhs < 0) {
*info = -3; *info = -3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -5; *info = -5;
} else if (*ldb < max(1,maxmn)) { } else if (*ldb < max(1,maxmn)) {
*info = -7; *info = -7;
} }
smlsiz = ilaenv_(&c__9, (char *)"DGELSD", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( smlsiz = ilaenv_(&c__9, (char *)"DGELSD", (char *)" ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
/* Compute workspace. */ /* Compute workspace. */
/* (Note: Comments in the code beginning (char *)"Workspace:" describe the */ /* (Note: Comments in the code beginning (char *)"Workspace:" describe the */
@ -360,151 +360,151 @@ f"> */
liwork = 1; liwork = 1;
minmn = max(1,minmn); minmn = max(1,minmn);
/* Computing MAX */ /* Computing MAX */
i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) / i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) /
log(2.)) + 1; log(2.)) + 1;
nlvl = max(i__1,0); nlvl = max(i__1,0);
if (*info == 0) { if (*info == 0) {
maxwrk = 0; maxwrk = 0;
liwork = minmn * 3 * nlvl + minmn * 11; liwork = minmn * 3 * nlvl + minmn * 11;
mm = *m; mm = *m;
if (*m >= *n && *m >= mnthr) { if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */ /* Path 1a - overdetermined, with many more rows than columns. */
mm = *n; mm = *n;
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, (char *)"DORMQR", (char *)"LT", i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, (char *)"DORMQR", (char *)"LT",
m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2); m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
} }
if (*m >= *n) { if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */ /* Path 1 - overdetermined or exactly determined. */
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, (char *)"DGEBRD" i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, (char *)"DGEBRD"
, (char *)" ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); , (char *)" ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR",
(char *)"QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); (char *)"QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, (char *)"DORMBR", i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, (char *)"DORMBR",
(char *)"PLN", n, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); (char *)"PLN", n, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing 2nd power */ /* Computing 2nd power */
i__1 = smlsiz + 1; i__1 = smlsiz + 1;
wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * * wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *
nrhs + i__1 * i__1; nrhs + i__1 * i__1;
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + wlalsd; i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2), i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2),
i__2 = *n * 3 + wlalsd; i__2 = *n * 3 + wlalsd;
minwrk = max(i__1,i__2); minwrk = max(i__1,i__2);
} }
if (*n > *m) { if (*n > *m) {
/* Computing 2nd power */ /* Computing 2nd power */
i__1 = smlsiz + 1; i__1 = smlsiz + 1;
wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * * wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *
nrhs + i__1 * i__1; nrhs + i__1 * i__1;
if (*n >= mnthr) { if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more columns */ /* Path 2a - underdetermined, with many more columns */
/* than rows. */ /* than rows. */
maxwrk = *m + *m * ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, maxwrk = *m + *m * ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1,
&c_n1, (ftnlen)6, (ftnlen)1); &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, m, &c_n1, &c_n1, ( ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, m, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(& i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, m, &c_n1, (ftnlen)6, ( c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, m, &c_n1, (ftnlen)6, (
ftnlen)3); ftnlen)3);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", m, nrhs, m, &c_n1, ( ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", m, nrhs, m, &c_n1, (
ftnlen)6, (ftnlen)3); ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
if (*nrhs > 1) { if (*nrhs > 1) {
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
} else { } else {
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1); i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
} }
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, (char *)"DORMLQ", i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, (char *)"DORMLQ",
(char *)"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2); (char *)"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd; i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* XXX: Ensure the Path 2a case below is triggered. The workspace */ /* XXX: Ensure the Path 2a case below is triggered. The workspace */
/* calculation should use queries for all routines eventually. */ /* calculation should use queries for all routines eventually. */
/* Computing MAX */ /* Computing MAX */
/* Computing MAX */ /* Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3; max(i__3,*nrhs), i__4 = *n - *m * 3;
i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4); i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
} else { } else {
/* Path 2 - remaining underdetermined cases. */ /* Path 2 - remaining underdetermined cases. */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR" i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR"
, (char *)"QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); , (char *)"QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, (char *)"DORMBR", i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, (char *)"DORMBR",
(char *)"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3); (char *)"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
/* Computing MAX */ /* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + wlalsd; i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
maxwrk = max(i__1,i__2); maxwrk = max(i__1,i__2);
} }
/* Computing MAX */ /* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2), i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2),
i__2 = *m * 3 + wlalsd; i__2 = *m * 3 + wlalsd;
minwrk = max(i__1,i__2); minwrk = max(i__1,i__2);
} }
minwrk = min(minwrk,maxwrk); minwrk = min(minwrk,maxwrk);
work[1] = (doublereal) maxwrk; work[1] = (doublereal) maxwrk;
iwork[1] = liwork; iwork[1] = liwork;
if (*lwork < minwrk && ! lquery) { if (*lwork < minwrk && ! lquery) {
*info = -12; *info = -12;
} }
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGELSD", &i__1, (ftnlen)6); xerbla_((char *)"DGELSD", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
goto L10; goto L10;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
*rank = 0; *rank = 0;
return 0; return 0;
} }
/* Get machine parameters. */ /* Get machine parameters. */
@ -523,26 +523,26 @@ f"> */
/* Scale matrix norm up to SMLNUM. */ /* Scale matrix norm up to SMLNUM. */
dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info, (ftnlen)1); info, (ftnlen)1);
iascl = 1; iascl = 1;
} else if (anrm > bignum) { } else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM. */ /* Scale matrix norm down to BIGNUM. */
dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info, (ftnlen)1); info, (ftnlen)1);
iascl = 2; iascl = 2;
} else if (anrm == 0.) { } else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */ /* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n); i__1 = max(*m,*n);
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb, (ftnlen) dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb, (ftnlen)
1); 1);
dlaset_((char *)"F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1, (ftnlen)1); dlaset_((char *)"F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1, (ftnlen)1);
*rank = 0; *rank = 0;
goto L10; goto L10;
} }
/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */ /* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
@ -553,24 +553,24 @@ f"> */
/* Scale matrix norm up to SMLNUM. */ /* Scale matrix norm up to SMLNUM. */
dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info, (ftnlen)1); info, (ftnlen)1);
ibscl = 1; ibscl = 1;
} else if (bnrm > bignum) { } else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM. */ /* Scale matrix norm down to BIGNUM. */
dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info, (ftnlen)1); info, (ftnlen)1);
ibscl = 2; ibscl = 2;
} }
/* If M < N make sure certain entries of B are zero. */ /* If M < N make sure certain entries of B are zero. */
if (*m < *n) { if (*m < *n) {
i__1 = *n - *m; i__1 = *n - *m;
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, ( dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, (
ftnlen)1); ftnlen)1);
} }
/* Overdetermined case. */ /* Overdetermined case. */
@ -579,227 +579,227 @@ f"> */
/* Path 1 - overdetermined or exactly determined. */ /* Path 1 - overdetermined or exactly determined. */
mm = *m; mm = *m;
if (*m >= mnthr) { if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */ /* Path 1a - overdetermined, with many more rows than columns. */
mm = *n; mm = *n;
itau = 1; itau = 1;
nwork = itau + *n; nwork = itau + *n;
/* Compute A=Q*R. */ /* Compute A=Q*R. */
/* (Workspace: need 2*N, prefer N+N*NB) */ /* (Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info); info);
/* Multiply B by transpose(Q). */ /* Multiply B by transpose(Q). */
/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */ /* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, (
ftnlen)1); ftnlen)1);
/* Zero out below R. */ /* Zero out below R. */
if (*n > 1) { if (*n > 1) {
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
dlaset_((char *)"L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], dlaset_((char *)"L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2],
lda, (ftnlen)1); lda, (ftnlen)1);
} }
} }
ie = 1; ie = 1;
itauq = ie + *n; itauq = ie + *n;
itaup = itauq + *n; itaup = itauq + *n;
nwork = itaup + *n; nwork = itaup + *n;
/* Bidiagonalize R in A. */ /* Bidiagonalize R in A. */
/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ /* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info); work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R. */ /* Multiply B by transpose of left bidiagonalizing vectors of R. */
/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ /* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
&b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, (
ftnlen)1, (ftnlen)1); ftnlen)1, (ftnlen)1);
/* Solve the bidiagonal least squares problem. */ /* Solve the bidiagonal least squares problem. */
dlalsd_((char *)"U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, dlalsd_((char *)"U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)1); rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)1);
if (*info != 0) { if (*info != 0) {
goto L10; goto L10;
} }
/* Multiply B by right bidiagonalizing vectors of R. */ /* Multiply B by right bidiagonalizing vectors of R. */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, n, &a[a_offset], lda, &work[itaup], & dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, (
ftnlen)1, (ftnlen)1); ftnlen)1, (ftnlen)1);
} else /* if(complicated condition) */ { } else /* if(complicated condition) */ {
/* Computing MAX */ /* Computing MAX */
i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max( i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2); i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2);
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) { if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) {
/* Path 2a - underdetermined, with many more columns than rows */ /* Path 2a - underdetermined, with many more columns than rows */
/* and sufficient workspace for an efficient algorithm. */ /* and sufficient workspace for an efficient algorithm. */
ldwork = *m; ldwork = *m;
/* Computing MAX */ /* Computing MAX */
/* Computing MAX */ /* Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3; max(i__3,*nrhs), i__4 = *n - *m * 3;
i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda + i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
*m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2) *m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2)
+ *m * *lda + wlalsd; + *m * *lda + wlalsd;
if (*lwork >= max(i__1,i__2)) { if (*lwork >= max(i__1,i__2)) {
ldwork = *lda; ldwork = *lda;
} }
itau = 1; itau = 1;
nwork = *m + 1; nwork = *m + 1;
/* Compute A=L*Q. */ /* Compute A=L*Q. */
/* (Workspace: need 2*M, prefer M+M*NB) */ /* (Workspace: need 2*M, prefer M+M*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info); info);
il = nwork; il = nwork;
/* Copy L to WORK(IL), zeroing out above its diagonal. */ /* Copy L to WORK(IL), zeroing out above its diagonal. */
dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen) dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen)
1); 1);
i__1 = *m - 1; i__1 = *m - 1;
i__2 = *m - 1; i__2 = *m - 1;
dlaset_((char *)"U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], & dlaset_((char *)"U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &
ldwork, (ftnlen)1); ldwork, (ftnlen)1);
ie = il + ldwork * *m; ie = il + ldwork * *m;
itauq = ie + *m; itauq = ie + *m;
itaup = itauq + *m; itaup = itauq + *m;
nwork = itaup + *m; nwork = itaup + *m;
/* Bidiagonalize L in WORK(IL). */ /* Bidiagonalize L in WORK(IL). */
/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ /* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
&work[itaup], &work[nwork], &i__1, info); &work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of L. */ /* Multiply B by transpose of left bidiagonalizing vectors of L. */
/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ /* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[ dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[nwork], &i__1, info, ( itauq], &b[b_offset], ldb, &work[nwork], &i__1, info, (
ftnlen)1, (ftnlen)1, (ftnlen)1); ftnlen)1, (ftnlen)1, (ftnlen)1);
/* Solve the bidiagonal least squares problem. */ /* Solve the bidiagonal least squares problem. */
dlalsd_((char *)"U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], dlalsd_((char *)"U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen) ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)
1); 1);
if (*info != 0) { if (*info != 0) {
goto L10; goto L10;
} }
/* Multiply B by right bidiagonalizing vectors of L. */ /* Multiply B by right bidiagonalizing vectors of L. */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"L", (char *)"N", m, nrhs, m, &work[il], &ldwork, &work[ dormbr_((char *)"P", (char *)"L", (char *)"N", m, nrhs, m, &work[il], &ldwork, &work[
itaup], &b[b_offset], ldb, &work[nwork], &i__1, info, ( itaup], &b[b_offset], ldb, &work[nwork], &i__1, info, (
ftnlen)1, (ftnlen)1, (ftnlen)1); ftnlen)1, (ftnlen)1, (ftnlen)1);
/* Zero out below first M rows of B. */ /* Zero out below first M rows of B. */
i__1 = *n - *m; i__1 = *n - *m;
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1],
ldb, (ftnlen)1); ldb, (ftnlen)1);
nwork = itau + *m; nwork = itau + *m;
/* Multiply transpose(Q) by B. */ /* Multiply transpose(Q) by B. */
/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */ /* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, (
ftnlen)1); ftnlen)1);
} else { } else {
/* Path 2 - remaining underdetermined cases. */ /* Path 2 - remaining underdetermined cases. */
ie = 1; ie = 1;
itauq = ie + *m; itauq = ie + *m;
itaup = itauq + *m; itaup = itauq + *m;
nwork = itaup + *m; nwork = itaup + *m;
/* Bidiagonalize A. */ /* Bidiagonalize A. */
/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ /* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info); work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors. */ /* Multiply B by transpose of left bidiagonalizing vectors. */
/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ /* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq] dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
, &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, , &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1,
(ftnlen)1, (ftnlen)1); (ftnlen)1, (ftnlen)1);
/* Solve the bidiagonal least squares problem. */ /* Solve the bidiagonal least squares problem. */
dlalsd_((char *)"L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], dlalsd_((char *)"L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen) ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)
1); 1);
if (*info != 0) { if (*info != 0) {
goto L10; goto L10;
} }
/* Multiply B by right bidiagonalizing vectors of A. */ /* Multiply B by right bidiagonalizing vectors of A. */
i__1 = *lwork - nwork + 1; i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, m, &a[a_offset], lda, &work[itaup] dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
, &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, , &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1,
(ftnlen)1, (ftnlen)1); (ftnlen)1, (ftnlen)1);
} }
} }
/* Undo scaling. */ /* Undo scaling. */
if (iascl == 1) { if (iascl == 1) {
dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1); info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, (ftnlen)1); minmn, info, (ftnlen)1);
} else if (iascl == 2) { } else if (iascl == 2) {
dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1); info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, (ftnlen)1); minmn, info, (ftnlen)1);
} }
if (ibscl == 1) { if (ibscl == 1) {
dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1); info, (ftnlen)1);
} else if (ibscl == 2) { } else if (ibscl == 2) {
dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1); info, (ftnlen)1);
} }
L10: L10:
@ -812,5 +812,5 @@ L10:
} /* dgelsd_ */ } /* dgelsd_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

906
lib/linalg/dgelss.cpp
View File

File diff suppressed because it is too large Load Diff

266
lib/linalg/dgemm.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgemm.f -- translated by f2c (version 20200916). /* fortran/dgemm.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -201,13 +201,13 @@ extern "C" {
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer * /* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
n, integer *k, doublereal *alpha, doublereal *a, integer *lda, n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
integer *ldc, ftnlen transa_len, ftnlen transb_len) integer *ldc, ftnlen transa_len, ftnlen transb_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3; i__3;
/* Local variables */ /* Local variables */
integer i__, j, l, info; integer i__, j, l, info;
@ -259,192 +259,192 @@ extern "C" {
nota = lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1); nota = lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1);
notb = lsame_(transb, (char *)"N", (ftnlen)1, (ftnlen)1); notb = lsame_(transb, (char *)"N", (ftnlen)1, (ftnlen)1);
if (nota) { if (nota) {
nrowa = *m; nrowa = *m;
} else { } else {
nrowa = *k; nrowa = *k;
} }
if (notb) { if (notb) {
nrowb = *k; nrowb = *k;
} else { } else {
nrowb = *n; nrowb = *n;
} }
/* Test the input parameters. */ /* Test the input parameters. */
info = 0; info = 0;
if (! nota && ! lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1) && ! lsame_( if (! nota && ! lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1) && ! lsame_(
transa, (char *)"T", (ftnlen)1, (ftnlen)1)) { transa, (char *)"T", (ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (! notb && ! lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1) && ! } else if (! notb && ! lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1) && !
lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) { lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) {
info = 2; info = 2;
} else if (*m < 0) { } else if (*m < 0) {
info = 3; info = 3;
} else if (*n < 0) { } else if (*n < 0) {
info = 4; info = 4;
} else if (*k < 0) { } else if (*k < 0) {
info = 5; info = 5;
} else if (*lda < max(1,nrowa)) { } else if (*lda < max(1,nrowa)) {
info = 8; info = 8;
} else if (*ldb < max(1,nrowb)) { } else if (*ldb < max(1,nrowb)) {
info = 10; info = 10;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
info = 13; info = 13;
} }
if (info != 0) { if (info != 0) {
xerbla_((char *)"DGEMM ", &info, (ftnlen)6); xerbla_((char *)"DGEMM ", &info, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
return 0; return 0;
} }
/* And if alpha.eq.zero. */ /* And if alpha.eq.zero. */
if (*alpha == 0.) { if (*alpha == 0.) {
if (*beta == 0.) { if (*beta == 0.) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.; c__[i__ + j * c_dim1] = 0.;
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
} }
return 0; return 0;
} }
/* Start the operations. */ /* Start the operations. */
if (notb) { if (notb) {
if (nota) { if (nota) {
/* Form C := alpha*A*B + beta*C. */ /* Form C := alpha*A*B + beta*C. */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) { if (*beta == 0.) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.; c__[i__ + j * c_dim1] = 0.;
/* L50: */ /* L50: */
} }
} else if (*beta != 1.) { } else if (*beta != 1.) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L60: */ /* L60: */
} }
} }
i__2 = *k; i__2 = *k;
for (l = 1; l <= i__2; ++l) { for (l = 1; l <= i__2; ++l) {
temp = *alpha * b[l + j * b_dim1]; temp = *alpha * b[l + j * b_dim1];
i__3 = *m; i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) { for (i__ = 1; i__ <= i__3; ++i__) {
c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1];
/* L70: */ /* L70: */
} }
/* L80: */ /* L80: */
} }
/* L90: */ /* L90: */
} }
} else { } else {
/* Form C := alpha*A**T*B + beta*C */ /* Form C := alpha*A**T*B + beta*C */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = 0.; temp = 0.;
i__3 = *k; i__3 = *k;
for (l = 1; l <= i__3; ++l) { for (l = 1; l <= i__3; ++l) {
temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
/* L100: */ /* L100: */
} }
if (*beta == 0.) { if (*beta == 0.) {
c__[i__ + j * c_dim1] = *alpha * temp; c__[i__ + j * c_dim1] = *alpha * temp;
} else { } else {
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
i__ + j * c_dim1]; i__ + j * c_dim1];
} }
/* L110: */ /* L110: */
} }
/* L120: */ /* L120: */
} }
} }
} else { } else {
if (nota) { if (nota) {
/* Form C := alpha*A*B**T + beta*C */ /* Form C := alpha*A*B**T + beta*C */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) { if (*beta == 0.) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.; c__[i__ + j * c_dim1] = 0.;
/* L130: */ /* L130: */
} }
} else if (*beta != 1.) { } else if (*beta != 1.) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L140: */ /* L140: */
} }
} }
i__2 = *k; i__2 = *k;
for (l = 1; l <= i__2; ++l) { for (l = 1; l <= i__2; ++l) {
temp = *alpha * b[j + l * b_dim1]; temp = *alpha * b[j + l * b_dim1];
i__3 = *m; i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) { for (i__ = 1; i__ <= i__3; ++i__) {
c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1];
/* L150: */ /* L150: */
} }
/* L160: */ /* L160: */
} }
/* L170: */ /* L170: */
} }
} else { } else {
/* Form C := alpha*A**T*B**T + beta*C */ /* Form C := alpha*A**T*B**T + beta*C */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = 0.; temp = 0.;
i__3 = *k; i__3 = *k;
for (l = 1; l <= i__3; ++l) { for (l = 1; l <= i__3; ++l) {
temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
/* L180: */ /* L180: */
} }
if (*beta == 0.) { if (*beta == 0.) {
c__[i__ + j * c_dim1] = *alpha * temp; c__[i__ + j * c_dim1] = *alpha * temp;
} else { } else {
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
i__ + j * c_dim1]; i__ + j * c_dim1];
} }
/* L190: */ /* L190: */
} }
/* L200: */ /* L200: */
} }
} }
} }
return 0; return 0;
@ -454,5 +454,5 @@ extern "C" {
} /* dgemm_ */ } /* dgemm_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

216
lib/linalg/dgemv.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgemv.f -- translated by f2c (version 20200916). /* fortran/dgemv.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -170,8 +170,8 @@ extern "C" {
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal * /* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
doublereal *beta, doublereal *y, integer *incy, ftnlen trans_len) doublereal *beta, doublereal *y, integer *incy, ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -218,50 +218,50 @@ extern "C" {
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"T", ( if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"T", (
ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1) ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)
) { ) {
info = 1; info = 1;
} else if (*m < 0) { } else if (*m < 0) {
info = 2; info = 2;
} else if (*n < 0) { } else if (*n < 0) {
info = 3; info = 3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
info = 6; info = 6;
} else if (*incx == 0) { } else if (*incx == 0) {
info = 8; info = 8;
} else if (*incy == 0) { } else if (*incy == 0) {
info = 11; info = 11;
} }
if (info != 0) { if (info != 0) {
xerbla_((char *)"DGEMV ", &info, (ftnlen)6); xerbla_((char *)"DGEMV ", &info, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
return 0; return 0;
} }
/* Set LENX and LENY, the lengths of the vectors x and y, and set */ /* Set LENX and LENY, the lengths of the vectors x and y, and set */
/* up the start points in X and Y. */ /* up the start points in X and Y. */
if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) {
lenx = *n; lenx = *n;
leny = *m; leny = *m;
} else { } else {
lenx = *m; lenx = *m;
leny = *n; leny = *n;
} }
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
} else { } else {
kx = 1 - (lenx - 1) * *incx; kx = 1 - (lenx - 1) * *incx;
} }
if (*incy > 0) { if (*incy > 0) {
ky = 1; ky = 1;
} else { } else {
ky = 1 - (leny - 1) * *incy; ky = 1 - (leny - 1) * *incy;
} }
/* Start the operations. In this version the elements of A are */ /* Start the operations. In this version the elements of A are */
@ -270,108 +270,108 @@ extern "C" {
/* First form y := beta*y. */ /* First form y := beta*y. */
if (*beta != 1.) { if (*beta != 1.) {
if (*incy == 1) { if (*incy == 1) {
if (*beta == 0.) { if (*beta == 0.) {
i__1 = leny; i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.; y[i__] = 0.;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = leny; i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__]; y[i__] = *beta * y[i__];
/* L20: */ /* L20: */
} }
} }
} else { } else {
iy = ky; iy = ky;
if (*beta == 0.) { if (*beta == 0.) {
i__1 = leny; i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.; y[iy] = 0.;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = leny; i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy]; y[iy] = *beta * y[iy];
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
} }
if (*alpha == 0.) { if (*alpha == 0.) {
return 0; return 0;
} }
if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) {
/* Form y := alpha*A*x + y. */ /* Form y := alpha*A*x + y. */
jx = kx; jx = kx;
if (*incy == 1) { if (*incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
temp = *alpha * x[jx]; temp = *alpha * x[jx];
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += temp * a[i__ + j * a_dim1]; y[i__] += temp * a[i__ + j * a_dim1];
/* L50: */ /* L50: */
} }
jx += *incx; jx += *incx;
/* L60: */ /* L60: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
temp = *alpha * x[jx]; temp = *alpha * x[jx];
iy = ky; iy = ky;
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
y[iy] += temp * a[i__ + j * a_dim1]; y[iy] += temp * a[i__ + j * a_dim1];
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
jx += *incx; jx += *incx;
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y := alpha*A**T*x + y. */ /* Form y := alpha*A**T*x + y. */
jy = ky; jy = ky;
if (*incx == 1) { if (*incx == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
temp = 0.; temp = 0.;
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp += a[i__ + j * a_dim1] * x[i__]; temp += a[i__ + j * a_dim1] * x[i__];
/* L90: */ /* L90: */
} }
y[jy] += *alpha * temp; y[jy] += *alpha * temp;
jy += *incy; jy += *incy;
/* L100: */ /* L100: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
temp = 0.; temp = 0.;
ix = kx; ix = kx;
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp += a[i__ + j * a_dim1] * x[ix]; temp += a[i__ + j * a_dim1] * x[ix];
ix += *incx; ix += *incx;
/* L110: */ /* L110: */
} }
y[jy] += *alpha * temp; y[jy] += *alpha * temp;
jy += *incy; jy += *incy;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
@ -381,5 +381,5 @@ extern "C" {
} /* dgemv_ */ } /* dgemv_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

68
lib/linalg/dgeqr2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgeqr2.f -- translated by f2c (version 20200916). /* fortran/dgeqr2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -152,7 +152,7 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info) lda, doublereal *tau, doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -160,11 +160,11 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, k; integer i__, k;
doublereal aii; doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *, extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *, doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen); ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -200,16 +200,16 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGEQR2", &i__1, (ftnlen)6); xerbla_((char *)"DGEQR2", &i__1, (ftnlen)6);
return 0; return 0;
} }
k = min(*m,*n); k = min(*m,*n);
@ -219,24 +219,24 @@ f"> */
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ /* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 1; i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1] dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1]
, &c__1, &tau[i__]); , &c__1, &tau[i__]);
if (i__ < *n) { if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */ /* Apply H(i) to A(i:m,i+1:n) from the left */
aii = a[i__ + i__ * a_dim1]; aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = *n - i__; i__3 = *n - i__;
dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[ dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4); ftnlen)4);
a[i__ + i__ * a_dim1] = aii; a[i__ + i__ * a_dim1] = aii;
} }
/* L10: */ /* L10: */
} }
return 0; return 0;
@ -246,5 +246,5 @@ f"> */
} /* dgeqr2_ */ } /* dgeqr2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

156
lib/linalg/dgeqrf.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgeqrf.f -- translated by f2c (version 20200916). /* fortran/dgeqrf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -170,23 +170,23 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4; integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, k, ib, nb, nx, iws, nbmin, iinfo; integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
char *, char *, char *, integer *, integer *, integer *, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen, *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer ldwork, lwkopt; integer ldwork, lwkopt;
logical lquery; logical lquery;
@ -225,38 +225,38 @@ f"> */
k = min(*m,*n); k = min(*m,*n);
*info = 0; *info = 0;
nb = ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) nb = ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1); 1);
lquery = *lwork == -1; lquery = *lwork == -1;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} else if (! lquery) { } else if (! lquery) {
if (*lwork <= 0 || *m > 0 && *lwork < max(1,*n)) { if (*lwork <= 0 || *m > 0 && *lwork < max(1,*n)) {
*info = -7; *info = -7;
} }
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGEQRF", &i__1, (ftnlen)6); xerbla_((char *)"DGEQRF", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
if (k == 0) { if (k == 0) {
lwkopt = 1; lwkopt = 1;
} else { } else {
lwkopt = *n * nb; lwkopt = *n * nb;
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (k == 0) { if (k == 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
@ -267,79 +267,79 @@ f"> */
/* Determine when to cross over from blocked to unblocked code. */ /* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */ /* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, ( i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2); nx = max(i__1,i__2);
if (nx < k) { if (nx < k) {
/* Determine if workspace is large enough for blocked code. */ /* Determine if workspace is large enough for blocked code. */
ldwork = *n; ldwork = *n;
iws = ldwork * nb; iws = ldwork * nb;
if (*lwork < iws) { if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */ /* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */ /* determine the minimum value of NB. */
nb = *lwork / ldwork; nb = *lwork / ldwork;
/* Computing MAX */ /* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, & i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1); c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
} }
if (nb >= nbmin && nb < k && nx < k) { if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */ /* Use blocked code initially */
i__1 = k - nx; i__1 = k - nx;
i__2 = nb; i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */ /* Computing MIN */
i__3 = k - i__ + 1; i__3 = k - i__ + 1;
ib = min(i__3,nb); ib = min(i__3,nb);
/* Compute the QR factorization of the current block */ /* Compute the QR factorization of the current block */
/* A(i:m,i:i+ib-1) */ /* A(i:m,i:i+ib-1) */
i__3 = *m - i__ + 1; i__3 = *m - i__ + 1;
dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo); 1], &iinfo);
if (i__ + ib <= *n) { if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */ /* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *m - i__ + 1; i__3 = *m - i__ + 1;
dlarft_((char *)"Forward", (char *)"Columnwise", &i__3, &ib, &a[i__ + i__ * dlarft_((char *)"Forward", (char *)"Columnwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)10); (ftnlen)10);
/* Apply H**T to A(i:m,i+ib:n) from the left */ /* Apply H**T to A(i:m,i+ib:n) from the left */
i__3 = *m - i__ + 1; i__3 = *m - i__ + 1;
i__4 = *n - i__ - ib + 1; i__4 = *n - i__ - ib + 1;
dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, & dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, &
i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib
+ 1], &ldwork, (ftnlen)4, (ftnlen)9, (ftnlen)7, ( + 1], &ldwork, (ftnlen)4, (ftnlen)9, (ftnlen)7, (
ftnlen)10); ftnlen)10);
} }
/* L10: */ /* L10: */
} }
} else { } else {
i__ = 1; i__ = 1;
} }
/* Use unblocked code to factor the last or only block. */ /* Use unblocked code to factor the last or only block. */
if (i__ <= k) { if (i__ <= k) {
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1; i__1 = *n - i__ + 1;
dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo); , &iinfo);
} }
work[1] = (doublereal) iws; work[1] = (doublereal) iws;
@ -350,5 +350,5 @@ f"> */
} /* dgeqrf_ */ } /* dgeqrf_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

100
lib/linalg/dger.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dger.f -- translated by f2c (version 20200916). /* fortran/dger.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -143,9 +143,9 @@ extern "C" {
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, /* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha,
doublereal *x, integer *incx, doublereal *y, integer *incy, doublereal *x, integer *incx, doublereal *y, integer *incy,
doublereal *a, integer *lda) doublereal *a, integer *lda)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -188,70 +188,70 @@ extern "C" {
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (*m < 0) { if (*m < 0) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
} else if (*incx == 0) { } else if (*incx == 0) {
info = 5; info = 5;
} else if (*incy == 0) { } else if (*incy == 0) {
info = 7; info = 7;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
info = 9; info = 9;
} }
if (info != 0) { if (info != 0) {
xerbla_((char *)"DGER ", &info, (ftnlen)6); xerbla_((char *)"DGER ", &info, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*m == 0 || *n == 0 || *alpha == 0.) { if (*m == 0 || *n == 0 || *alpha == 0.) {
return 0; return 0;
} }
/* Start the operations. In this version the elements of A are */ /* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */ /* accessed sequentially with one pass through A. */
if (*incy > 0) { if (*incy > 0) {
jy = 1; jy = 1;
} else { } else {
jy = 1 - (*n - 1) * *incy; jy = 1 - (*n - 1) * *incy;
} }
if (*incx == 1) { if (*incx == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
if (y[jy] != 0.) { if (y[jy] != 0.) {
temp = *alpha * y[jy]; temp = *alpha * y[jy];
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[i__] * temp; a[i__ + j * a_dim1] += x[i__] * temp;
/* L10: */ /* L10: */
} }
} }
jy += *incy; jy += *incy;
/* L20: */ /* L20: */
} }
} else { } else {
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
} else { } else {
kx = 1 - (*m - 1) * *incx; kx = 1 - (*m - 1) * *incx;
} }
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
if (y[jy] != 0.) { if (y[jy] != 0.) {
temp = *alpha * y[jy]; temp = *alpha * y[jy];
ix = kx; ix = kx;
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[ix] * temp; a[i__ + j * a_dim1] += x[ix] * temp;
ix += *incx; ix += *incx;
/* L30: */ /* L30: */
} }
} }
jy += *incy; jy += *incy;
/* L40: */ /* L40: */
} }
} }
return 0; return 0;
@ -261,5 +261,5 @@ extern "C" {
} /* dger_ */ } /* dger_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

46
lib/linalg/dgesv.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgesv.f -- translated by f2c (version 20200916). /* fortran/dgesv.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -138,17 +138,17 @@ extern "C" {
/* > \ingroup doubleGEsolve */ /* > \ingroup doubleGEsolve */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer /* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer
*lda, integer *ipiv, doublereal *b, integer *ldb, integer *info) *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1; integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */ /* Local variables */
extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *, extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *, integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen), dgetrs_(char *, integer *, integer *, doublereal *, ftnlen), dgetrs_(char *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *, ftnlen); integer *, integer *, doublereal *, integer *, integer *, ftnlen);
/* -- LAPACK driver routine -- */ /* -- LAPACK driver routine -- */
@ -182,18 +182,18 @@ extern "C" {
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*n < 0) { if (*n < 0) {
*info = -1; *info = -1;
} else if (*nrhs < 0) { } else if (*nrhs < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*n)) { } else if (*lda < max(1,*n)) {
*info = -4; *info = -4;
} else if (*ldb < max(1,*n)) { } else if (*ldb < max(1,*n)) {
*info = -7; *info = -7;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGESV ", &i__1, (ftnlen)6); xerbla_((char *)"DGESV ", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Compute the LU factorization of A. */ /* Compute the LU factorization of A. */
@ -203,8 +203,8 @@ extern "C" {
/* Solve the system A*X = B, overwriting B with X. */ /* Solve the system A*X = B, overwriting B with X. */
dgetrs_((char *)"No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[ dgetrs_((char *)"No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
b_offset], ldb, info, (ftnlen)12); b_offset], ldb, info, (ftnlen)12);
} }
return 0; return 0;
@ -213,5 +213,5 @@ extern "C" {
} /* dgesv_ */ } /* dgesv_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

4106
lib/linalg/dgesvd.cpp
View File

File diff suppressed because it is too large Load Diff

100
lib/linalg/dgetf2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgetf2.f -- translated by f2c (version 20200916). /* fortran/dgetf2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -131,7 +131,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info) lda, integer *ipiv, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -139,13 +139,13 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, j, jp; integer i__, j, jp;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dscal_(integer *, doublereal *, doublereal *, integer integer *), dscal_(integer *, doublereal *, doublereal *, integer
*); *);
doublereal sfmin; doublereal sfmin;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
@ -185,22 +185,22 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGETF2", &i__1, (ftnlen)6); xerbla_((char *)"DGETF2", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
return 0; return 0;
} }
/* Compute machine safe minimum */ /* Compute machine safe minimum */
@ -212,47 +212,47 @@ f"> */
/* Find pivot and test for singularity. */ /* Find pivot and test for singularity. */
i__2 = *m - j + 1; i__2 = *m - j + 1;
jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1); jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp; ipiv[j] = jp;
if (a[jp + j * a_dim1] != 0.) { if (a[jp + j * a_dim1] != 0.) {
/* Apply the interchange to columns 1:N. */ /* Apply the interchange to columns 1:N. */
if (jp != j) { if (jp != j) {
dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
} }
/* Compute elements J+1:M of J-th column. */ /* Compute elements J+1:M of J-th column. */
if (j < *m) { if (j < *m) {
if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) { if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) {
i__2 = *m - j; i__2 = *m - j;
d__1 = 1. / a[j + j * a_dim1]; d__1 = 1. / a[j + j * a_dim1];
dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
} else { } else {
i__2 = *m - j; i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[j + i__ + j * a_dim1] /= a[j + j * a_dim1]; a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
/* L20: */ /* L20: */
} }
} }
} }
} else if (*info == 0) { } else if (*info == 0) {
*info = j; *info = j;
} }
if (j < min(*m,*n)) { if (j < min(*m,*n)) {
/* Update trailing submatrix. */ /* Update trailing submatrix. */
i__2 = *m - j; i__2 = *m - j;
i__3 = *n - j; i__3 = *n - j;
dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + ( dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda); j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
} }
/* L10: */ /* L10: */
} }
return 0; return 0;
@ -262,5 +262,5 @@ f"> */
} /* dgetf2_ */ } /* dgetf2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

136
lib/linalg/dgetrf.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgetrf.f -- translated by f2c (version 20200916). /* fortran/dgetrf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -132,26 +132,26 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info) lda, integer *ipiv, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */ /* Local variables */
integer i__, j, jb, nb; integer i__, j, jb, nb;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
integer iinfo; integer iinfo;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_(
char *, integer *, ftnlen); char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *, extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *), dgetrf2_(integer *, integer *, integer *, integer *, integer *), dgetrf2_(integer *,
integer *, doublereal *, integer *, integer *, integer *); integer *, doublereal *, integer *, integer *, integer *);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -188,99 +188,99 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGETRF", &i__1, (ftnlen)6); xerbla_((char *)"DGETRF", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
return 0; return 0;
} }
/* Determine the block size for this environment. */ /* Determine the block size for this environment. */
nb = ilaenv_(&c__1, (char *)"DGETRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) nb = ilaenv_(&c__1, (char *)"DGETRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1); 1);
if (nb <= 1 || nb >= min(*m,*n)) { if (nb <= 1 || nb >= min(*m,*n)) {
/* Use unblocked code. */ /* Use unblocked code. */
dgetrf2_(m, n, &a[a_offset], lda, &ipiv[1], info); dgetrf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
} else { } else {
/* Use blocked code. */ /* Use blocked code. */
i__1 = min(*m,*n); i__1 = min(*m,*n);
i__2 = nb; i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */ /* Computing MIN */
i__3 = min(*m,*n) - j + 1; i__3 = min(*m,*n) - j + 1;
jb = min(i__3,nb); jb = min(i__3,nb);
/* Factor diagonal and subdiagonal blocks and test for exact */ /* Factor diagonal and subdiagonal blocks and test for exact */
/* singularity. */ /* singularity. */
i__3 = *m - j + 1; i__3 = *m - j + 1;
dgetrf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo); dgetrf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
/* Adjust INFO and the pivot indices. */ /* Adjust INFO and the pivot indices. */
if (*info == 0 && iinfo > 0) { if (*info == 0 && iinfo > 0) {
*info = iinfo + j - 1; *info = iinfo + j - 1;
} }
/* Computing MIN */ /* Computing MIN */
i__4 = *m, i__5 = j + jb - 1; i__4 = *m, i__5 = j + jb - 1;
i__3 = min(i__4,i__5); i__3 = min(i__4,i__5);
for (i__ = j; i__ <= i__3; ++i__) { for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = j - 1 + ipiv[i__]; ipiv[i__] = j - 1 + ipiv[i__];
/* L10: */ /* L10: */
} }
/* Apply interchanges to columns 1:J-1. */ /* Apply interchanges to columns 1:J-1. */
i__3 = j - 1; i__3 = j - 1;
i__4 = j + jb - 1; i__4 = j + jb - 1;
dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1); dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
if (j + jb <= *n) { if (j + jb <= *n) {
/* Apply interchanges to columns J+JB:N. */ /* Apply interchanges to columns J+JB:N. */
i__3 = *n - j - jb + 1; i__3 = *n - j - jb + 1;
i__4 = j + jb - 1; i__4 = j + jb - 1;
dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, & dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
ipiv[1], &c__1); ipiv[1], &c__1);
/* Compute block row of U. */ /* Compute block row of U. */
i__3 = *n - j - jb + 1; i__3 = *n - j - jb + 1;
dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", &jb, &i__3, & dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", &jb, &i__3, &
c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) * c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
a_dim1], lda, (ftnlen)4, (ftnlen)5, (ftnlen)12, ( a_dim1], lda, (ftnlen)4, (ftnlen)5, (ftnlen)12, (
ftnlen)4); ftnlen)4);
if (j + jb <= *m) { if (j + jb <= *m) {
/* Update trailing submatrix. */ /* Update trailing submatrix. */
i__3 = *m - j - jb + 1; i__3 = *m - j - jb + 1;
i__4 = *n - j - jb + 1; i__4 = *n - j - jb + 1;
dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb, dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb,
&c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j + &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j +
jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) * jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) *
a_dim1], lda, (ftnlen)12, (ftnlen)12); a_dim1], lda, (ftnlen)12, (ftnlen)12);
} }
} }
/* L20: */ /* L20: */
} }
} }
return 0; return 0;
@ -289,5 +289,5 @@ f"> */
} /* dgetrf_ */ } /* dgetrf_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

158
lib/linalg/dgetrf2.cpp
View File

@ -1,13 +1,13 @@
/* static/dgetrf2.f -- translated by f2c (version 20200916). /* static/dgetrf2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -133,7 +133,7 @@ static doublereal c_b16 = -1.;
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgetrf2_(integer *m, integer *n, doublereal *a, integer * /* Subroutine */ int dgetrf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info) lda, integer *ipiv, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -142,20 +142,20 @@ static doublereal c_b16 = -1.;
/* Local variables */ /* Local variables */
integer i__, n1, n2; integer i__, n1, n2;
doublereal temp; doublereal temp;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer * integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *, , doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen, ftnlen); doublereal *, doublereal *, integer *, ftnlen, ftnlen);
integer iinfo; integer iinfo;
doublereal sfmin; doublereal sfmin;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlaswp_( extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlaswp_(
integer *, doublereal *, integer *, integer *, integer *, integer integer *, doublereal *, integer *, integer *, integer *, integer
*, integer *); *, integer *);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -192,32 +192,32 @@ static doublereal c_b16 = -1.;
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -4; *info = -4;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGETRF2", &i__1, (ftnlen)7); xerbla_((char *)"DGETRF2", &i__1, (ftnlen)7);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
return 0; return 0;
} }
if (*m == 1) { if (*m == 1) {
/* Use unblocked code for one row case */ /* Use unblocked code for one row case */
/* Just need to handle IPIV and INFO */ /* Just need to handle IPIV and INFO */
ipiv[1] = 1; ipiv[1] = 1;
if (a[a_dim1 + 1] == 0.) { if (a[a_dim1 + 1] == 0.) {
*info = 1; *info = 1;
} }
} else if (*n == 1) { } else if (*n == 1) {
@ -226,98 +226,98 @@ static doublereal c_b16 = -1.;
/* Compute machine safe minimum */ /* Compute machine safe minimum */
sfmin = dlamch_((char *)"S", (ftnlen)1); sfmin = dlamch_((char *)"S", (ftnlen)1);
/* Find pivot and test for singularity */ /* Find pivot and test for singularity */
i__ = idamax_(m, &a[a_dim1 + 1], &c__1); i__ = idamax_(m, &a[a_dim1 + 1], &c__1);
ipiv[1] = i__; ipiv[1] = i__;
if (a[i__ + a_dim1] != 0.) { if (a[i__ + a_dim1] != 0.) {
/* Apply the interchange */ /* Apply the interchange */
if (i__ != 1) { if (i__ != 1) {
temp = a[a_dim1 + 1]; temp = a[a_dim1 + 1];
a[a_dim1 + 1] = a[i__ + a_dim1]; a[a_dim1 + 1] = a[i__ + a_dim1];
a[i__ + a_dim1] = temp; a[i__ + a_dim1] = temp;
} }
/* Compute elements 2:M of the column */ /* Compute elements 2:M of the column */
if ((d__1 = a[a_dim1 + 1], abs(d__1)) >= sfmin) { if ((d__1 = a[a_dim1 + 1], abs(d__1)) >= sfmin) {
i__1 = *m - 1; i__1 = *m - 1;
d__1 = 1. / a[a_dim1 + 1]; d__1 = 1. / a[a_dim1 + 1];
dscal_(&i__1, &d__1, &a[a_dim1 + 2], &c__1); dscal_(&i__1, &d__1, &a[a_dim1 + 2], &c__1);
} else { } else {
i__1 = *m - 1; i__1 = *m - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + 1 + a_dim1] /= a[a_dim1 + 1]; a[i__ + 1 + a_dim1] /= a[a_dim1 + 1];
/* L10: */ /* L10: */
} }
} }
} else { } else {
*info = 1; *info = 1;
} }
} else { } else {
/* Use recursive code */ /* Use recursive code */
n1 = min(*m,*n) / 2; n1 = min(*m,*n) / 2;
n2 = *n - n1; n2 = *n - n1;
/* [ A11 ] */ /* [ A11 ] */
/* Factor [ --- ] */ /* Factor [ --- ] */
/* [ A21 ] */ /* [ A21 ] */
dgetrf2_(m, &n1, &a[a_offset], lda, &ipiv[1], &iinfo); dgetrf2_(m, &n1, &a[a_offset], lda, &ipiv[1], &iinfo);
if (*info == 0 && iinfo > 0) { if (*info == 0 && iinfo > 0) {
*info = iinfo; *info = iinfo;
} }
/* [ A12 ] */ /* [ A12 ] */
/* Apply interchanges to [ --- ] */ /* Apply interchanges to [ --- ] */
/* [ A22 ] */ /* [ A22 ] */
dlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], & dlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], &
c__1); c__1);
/* Solve A12 */ /* Solve A12 */
dtrsm_((char *)"L", (char *)"L", (char *)"N", (char *)"U", &n1, &n2, &c_b13, &a[a_offset], lda, &a[( dtrsm_((char *)"L", (char *)"L", (char *)"N", (char *)"U", &n1, &n2, &c_b13, &a[a_offset], lda, &a[(
n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, ( n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (
ftnlen)1); ftnlen)1);
/* Update A22 */ /* Update A22 */
i__1 = *m - n1; i__1 = *m - n1;
dgemm_((char *)"N", (char *)"N", &i__1, &n2, &n1, &c_b16, &a[n1 + 1 + a_dim1], lda, & dgemm_((char *)"N", (char *)"N", &i__1, &n2, &n1, &c_b16, &a[n1 + 1 + a_dim1], lda, &
a[(n1 + 1) * a_dim1 + 1], lda, &c_b13, &a[n1 + 1 + (n1 + 1) * a[(n1 + 1) * a_dim1 + 1], lda, &c_b13, &a[n1 + 1 + (n1 + 1) *
a_dim1], lda, (ftnlen)1, (ftnlen)1); a_dim1], lda, (ftnlen)1, (ftnlen)1);
/* Factor A22 */ /* Factor A22 */
i__1 = *m - n1; i__1 = *m - n1;
dgetrf2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &ipiv[n1 + dgetrf2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &ipiv[n1 +
1], &iinfo); 1], &iinfo);
/* Adjust INFO and the pivot indices */ /* Adjust INFO and the pivot indices */
if (*info == 0 && iinfo > 0) { if (*info == 0 && iinfo > 0) {
*info = iinfo + n1; *info = iinfo + n1;
} }
i__1 = min(*m,*n); i__1 = min(*m,*n);
for (i__ = n1 + 1; i__ <= i__1; ++i__) { for (i__ = n1 + 1; i__ <= i__1; ++i__) {
ipiv[i__] += n1; ipiv[i__] += n1;
/* L20: */ /* L20: */
} }
/* Apply interchanges to A21 */ /* Apply interchanges to A21 */
i__1 = n1 + 1; i__1 = n1 + 1;
i__2 = min(*m,*n); i__2 = min(*m,*n);
dlaswp_(&n1, &a[a_dim1 + 1], lda, &i__1, &i__2, &ipiv[1], &c__1); dlaswp_(&n1, &a[a_dim1 + 1], lda, &i__1, &i__2, &ipiv[1], &c__1);
} }
return 0; return 0;
@ -327,5 +327,5 @@ static doublereal c_b16 = -1.;
} /* dgetrf2_ */ } /* dgetrf2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

172
lib/linalg/dgetri.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgetri.f -- translated by f2c (version 20200916). /* fortran/dgetri.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -138,31 +138,31 @@ f"> */
/* > \ingroup doubleGEcomputational */ /* > \ingroup doubleGEcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer /* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer
*ipiv, doublereal *work, integer *lwork, integer *info) *ipiv, doublereal *work, integer *lwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */ /* Local variables */
integer i__, j, jb, nb, jj, jp, nn, iws; integer i__, j, jb, nb, jj, jp, nn, iws;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen),
dgemv_(char *, integer *, integer *, doublereal *, doublereal *, dgemv_(char *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, ftnlen); integer *, ftnlen);
integer nbmin; integer nbmin;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dtrsm_(char *, char *, char *, char *, doublereal *, integer *), dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_(
char *, integer *, ftnlen); char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer ldwork; integer ldwork;
extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal
*, integer *, integer *, ftnlen, ftnlen); *, integer *, integer *, ftnlen, ftnlen);
integer lwkopt; integer lwkopt;
logical lquery; logical lquery;
@ -202,55 +202,55 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
nb = ilaenv_(&c__1, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( nb = ilaenv_(&c__1, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1); ftnlen)1);
lwkopt = *n * nb; lwkopt = *n * nb;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
lquery = *lwork == -1; lquery = *lwork == -1;
if (*n < 0) { if (*n < 0) {
*info = -1; *info = -1;
} else if (*lda < max(1,*n)) { } else if (*lda < max(1,*n)) {
*info = -3; *info = -3;
} else if (*lwork < max(1,*n) && ! lquery) { } else if (*lwork < max(1,*n) && ! lquery) {
*info = -6; *info = -6;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGETRI", &i__1, (ftnlen)6); xerbla_((char *)"DGETRI", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
/* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */ /* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */
/* and the inverse is not computed. */ /* and the inverse is not computed. */
dtrtri_((char *)"Upper", (char *)"Non-unit", n, &a[a_offset], lda, info, (ftnlen)5, ( dtrtri_((char *)"Upper", (char *)"Non-unit", n, &a[a_offset], lda, info, (ftnlen)5, (
ftnlen)8); ftnlen)8);
if (*info > 0) { if (*info > 0) {
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
ldwork = *n; ldwork = *n;
if (nb > 1 && nb < *n) { if (nb > 1 && nb < *n) {
/* Computing MAX */ /* Computing MAX */
i__1 = ldwork * nb; i__1 = ldwork * nb;
iws = max(i__1,1); iws = max(i__1,1);
if (*lwork < iws) { if (*lwork < iws) {
nb = *lwork / ldwork; nb = *lwork / ldwork;
/* Computing MAX */ /* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, & i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1); c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} else { } else {
iws = *n; iws = *n;
} }
/* Solve the equation inv(A)*L = inv(U) for inv(A). */ /* Solve the equation inv(A)*L = inv(U) for inv(A). */
@ -259,75 +259,75 @@ f"> */
/* Use unblocked code. */ /* Use unblocked code. */
for (j = *n; j >= 1; --j) { for (j = *n; j >= 1; --j) {
/* Copy current column of L to WORK and replace with zeros. */ /* Copy current column of L to WORK and replace with zeros. */
i__1 = *n; i__1 = *n;
for (i__ = j + 1; i__ <= i__1; ++i__) { for (i__ = j + 1; i__ <= i__1; ++i__) {
work[i__] = a[i__ + j * a_dim1]; work[i__] = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = 0.; a[i__ + j * a_dim1] = 0.;
/* L10: */ /* L10: */
} }
/* Compute current column of inv(A). */ /* Compute current column of inv(A). */
if (j < *n) { if (j < *n) {
i__1 = *n - j; i__1 = *n - j;
dgemv_((char *)"No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1 dgemv_((char *)"No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1
+ 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1 + 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1
+ 1], &c__1, (ftnlen)12); + 1], &c__1, (ftnlen)12);
} }
/* L20: */ /* L20: */
} }
} else { } else {
/* Use blocked code. */ /* Use blocked code. */
nn = (*n - 1) / nb * nb + 1; nn = (*n - 1) / nb * nb + 1;
i__1 = -nb; i__1 = -nb;
for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) { for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
/* Computing MIN */ /* Computing MIN */
i__2 = nb, i__3 = *n - j + 1; i__2 = nb, i__3 = *n - j + 1;
jb = min(i__2,i__3); jb = min(i__2,i__3);
/* Copy current block column of L to WORK and replace with */ /* Copy current block column of L to WORK and replace with */
/* zeros. */ /* zeros. */
i__2 = j + jb - 1; i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) { for (jj = j; jj <= i__2; ++jj) {
i__3 = *n; i__3 = *n;
for (i__ = jj + 1; i__ <= i__3; ++i__) { for (i__ = jj + 1; i__ <= i__3; ++i__) {
work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1]; work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1];
a[i__ + jj * a_dim1] = 0.; a[i__ + jj * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
/* Compute current block column of inv(A). */ /* Compute current block column of inv(A). */
if (j + jb <= *n) { if (j + jb <= *n) {
i__2 = *n - j - jb + 1; i__2 = *n - j - jb + 1;
dgemm_((char *)"No transpose", (char *)"No transpose", n, &jb, &i__2, &c_b20, dgemm_((char *)"No transpose", (char *)"No transpose", n, &jb, &i__2, &c_b20,
&a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], & &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &
ldwork, &c_b22, &a[j * a_dim1 + 1], lda, (ftnlen)12, ( ldwork, &c_b22, &a[j * a_dim1 + 1], lda, (ftnlen)12, (
ftnlen)12); ftnlen)12);
} }
dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, &jb, &c_b22, & dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, &jb, &c_b22, &
work[j], &ldwork, &a[j * a_dim1 + 1], lda, (ftnlen)5, ( work[j], &ldwork, &a[j * a_dim1 + 1], lda, (ftnlen)5, (
ftnlen)5, (ftnlen)12, (ftnlen)4); ftnlen)5, (ftnlen)12, (ftnlen)4);
/* L50: */ /* L50: */
} }
} }
/* Apply column interchanges. */ /* Apply column interchanges. */
for (j = *n - 1; j >= 1; --j) { for (j = *n - 1; j >= 1; --j) {
jp = ipiv[j]; jp = ipiv[j];
if (jp != j) { if (jp != j) {
dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1); dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
} }
/* L60: */ /* L60: */
} }
@ -339,5 +339,5 @@ f"> */
} /* dgetri_ */ } /* dgetri_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

80
lib/linalg/dgetrs.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dgetrs.f -- translated by f2c (version 20200916). /* fortran/dgetrs.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -143,20 +143,20 @@ f"> */
/* > \ingroup doubleGEcomputational */ /* > \ingroup doubleGEcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs, /* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs,
doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
ldb, integer *info, ftnlen trans_len) ldb, integer *info, ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1; integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */ /* Local variables */
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_(
char *, integer *, ftnlen), dlaswp_(integer *, doublereal *, char *, integer *, ftnlen), dlaswp_(integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *); integer *, integer *, integer *, integer *, integer *);
logical notran; logical notran;
@ -198,27 +198,27 @@ f"> */
*info = 0; *info = 0;
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_( if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(
trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { trans, (char *)"C", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*nrhs < 0) { } else if (*nrhs < 0) {
*info = -3; *info = -3;
} else if (*lda < max(1,*n)) { } else if (*lda < max(1,*n)) {
*info = -5; *info = -5;
} else if (*ldb < max(1,*n)) { } else if (*ldb < max(1,*n)) {
*info = -8; *info = -8;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DGETRS", &i__1, (ftnlen)6); xerbla_((char *)"DGETRS", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0 || *nrhs == 0) { if (*n == 0 || *nrhs == 0) {
return 0; return 0;
} }
if (notran) { if (notran) {
@ -227,38 +227,38 @@ f"> */
/* Apply row interchanges to the right hand sides. */ /* Apply row interchanges to the right hand sides. */
dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
/* Solve L*X = B, overwriting B with X. */ /* Solve L*X = B, overwriting B with X. */
dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, nrhs, &c_b12, &a[ dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (
ftnlen)12, (ftnlen)4); ftnlen)12, (ftnlen)4);
/* Solve U*X = B, overwriting B with X. */ /* Solve U*X = B, overwriting B with X. */
dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b12, & dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b12, &
a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (
ftnlen)12, (ftnlen)8); ftnlen)12, (ftnlen)8);
} else { } else {
/* Solve A**T * X = B. */ /* Solve A**T * X = B. */
/* Solve U**T *X = B, overwriting B with X. */ /* Solve U**T *X = B, overwriting B with X. */
dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b12, &a[ dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (
ftnlen)9, (ftnlen)8); ftnlen)9, (ftnlen)8);
/* Solve L**T *X = B, overwriting B with X. */ /* Solve L**T *X = B, overwriting B with X. */
dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, nrhs, &c_b12, &a[ dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (
ftnlen)9, (ftnlen)4); ftnlen)9, (ftnlen)4);
/* Apply row interchanges to the solution vectors. */ /* Apply row interchanges to the solution vectors. */
dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
} }
return 0; return 0;
@ -268,5 +268,5 @@ f"> */
} /* dgetrs_ */ } /* dgetrs_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

20
lib/linalg/dlabad.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlabad.f -- translated by f2c (version 20200916). /* fortran/dlabad.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -113,8 +113,8 @@ f"> */
/* SMALL and LARGE to avoid overflow and underflow problems. */ /* SMALL and LARGE to avoid overflow and underflow problems. */
if (d_lg10(large) > 2e3) { if (d_lg10(large) > 2e3) {
*small = sqrt(*small); *small = sqrt(*small);
*large = sqrt(*large); *large = sqrt(*large);
} }
return 0; return 0;
@ -124,5 +124,5 @@ f"> */
} /* dlabad_ */ } /* dlabad_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

392
lib/linalg/dlabrd.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlabrd.f -- translated by f2c (version 20200916). /* fortran/dlabrd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -233,21 +233,21 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal * /* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq, a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq,
doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer
*ldy) *ldy)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3; i__3;
/* Local variables */ /* Local variables */
integer i__; integer i__;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *, integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *, doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *); doublereal *, integer *, doublereal *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -290,236 +290,236 @@ f"> */
/* Function Body */ /* Function Body */
if (*m <= 0 || *n <= 0) { if (*m <= 0 || *n <= 0) {
return 0; return 0;
} }
if (*m >= *n) { if (*m >= *n) {
/* Reduce to upper bidiagonal form */ /* Reduce to upper bidiagonal form */
i__1 = *nb; i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */ /* Update A(i:m,i) */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda,
&y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], & &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], &
c__1, (ftnlen)12); c__1, (ftnlen)12);
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx,
&a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ * &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ *
a_dim1], &c__1, (ftnlen)12); a_dim1], &c__1, (ftnlen)12);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */ /* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 1; i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ *
a_dim1], &c__1, &tauq[i__]); a_dim1], &c__1, &tauq[i__]);
d__[i__] = a[i__ + i__ * a_dim1]; d__[i__] = a[i__ + i__ * a_dim1];
if (i__ < *n) { if (i__ < *n) {
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
/* Compute Y(i+1:n,i) */ /* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) *
a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, & a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &
y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9);
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1],
lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
y_dim1 + 1], &c__1, (ftnlen)9); y_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *n - i__; i__2 = *n - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12);
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1],
ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
y_dim1 + 1], &c__1, (ftnlen)9); y_dim1 + 1], &c__1, (ftnlen)9);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5,
&y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9);
i__2 = *n - i__; i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */ /* Update A(i,i+1:n) */
i__2 = *n - i__; i__2 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + ( y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (
i__ + 1) * a_dim1], lda, (ftnlen)12); i__ + 1) * a_dim1], lda, (ftnlen)12);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[ a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[
i__ + (i__ + 1) * a_dim1], lda, (ftnlen)9); i__ + (i__ + 1) * a_dim1], lda, (ftnlen)9);
/* Generate reflection P(i) to annihilate A(i,i+2:n) */ /* Generate reflection P(i) to annihilate A(i,i+2:n) */
i__2 = *n - i__; i__2 = *n - i__;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 2; i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min( dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
i__3,*n) * a_dim1], lda, &taup[i__]); i__3,*n) * a_dim1], lda, &taup[i__]);
e[i__] = a[i__ + (i__ + 1) * a_dim1]; e[i__] = a[i__ + (i__ + 1) * a_dim1];
a[i__ + (i__ + 1) * a_dim1] = 1.; a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute X(i+1:m,i) */ /* Compute X(i+1:m,i) */
i__2 = *m - i__; i__2 = *m - i__;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__
+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, ( lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, (
ftnlen)12); ftnlen)12);
i__2 = *n - i__; i__2 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1],
ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[ ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[
i__ * x_dim1 + 1], &c__1, (ftnlen)9); i__ * x_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *m - i__; i__2 = *m - i__;
dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b16, &x[i__ * x_dim1 + 1], &c__1, (ftnlen)12); c_b16, &x[i__ * x_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *m - i__; i__2 = *m - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
i__2 = *m - i__; i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
} }
/* L10: */ /* L10: */
} }
} else { } else {
/* Reduce to lower bidiagonal form */ /* Reduce to lower bidiagonal form */
i__1 = *nb; i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */ /* Update A(i,i:n) */
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1], &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1],
lda, (ftnlen)12); lda, (ftnlen)12);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1],
lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1],
lda, (ftnlen)9); lda, (ftnlen)9);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */ /* Generate reflection P(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 1; i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) *
a_dim1], lda, &taup[i__]); a_dim1], lda, &taup[i__]);
d__[i__] = a[i__ + i__ * a_dim1]; d__[i__] = a[i__ + i__ * a_dim1];
if (i__ < *m) { if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
/* Compute X(i+1:m,i) */ /* Compute X(i+1:m,i) */
i__2 = *m - i__; i__2 = *m - i__;
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ * dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ *
a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, & a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &
x[i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); x[i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1],
ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
x_dim1 + 1], &c__1, (ftnlen)9); x_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *m - i__; i__2 = *m - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 +
1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
x_dim1 + 1], &c__1, (ftnlen)12); x_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *m - i__; i__2 = *m - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
i__2 = *m - i__; i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
/* Update A(i+1:m,i) */ /* Update A(i+1:m,i) */
i__2 = *m - i__; i__2 = *m - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ +
1 + i__ * a_dim1], &c__1, (ftnlen)12); 1 + i__ * a_dim1], &c__1, (ftnlen)12);
i__2 = *m - i__; i__2 = *m - i__;
dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[ x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[
i__ + 1 + i__ * a_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * a_dim1], &c__1, (ftnlen)12);
/* Generate reflection Q(i) to annihilate A(i+2:m,i) */ /* Generate reflection Q(i) to annihilate A(i+2:m,i) */
i__2 = *m - i__; i__2 = *m - i__;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 2; i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) +
i__ * a_dim1], &c__1, &tauq[i__]); i__ * a_dim1], &c__1, &tauq[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1]; e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.; a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute Y(i+1:n,i) */ /* Compute Y(i+1:n,i) */
i__2 = *m - i__; i__2 = *m - i__;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ +
1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1,
&c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9);
i__2 = *m - i__; i__2 = *m - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
i__ * y_dim1 + 1], &c__1, (ftnlen)9); i__ * y_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *n - i__; i__2 = *n - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12);
i__2 = *m - i__; i__2 = *m - i__;
dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1],
ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
i__ * y_dim1 + 1], &c__1, (ftnlen)9); i__ * y_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *n - i__; i__2 = *n - i__;
dgemv_((char *)"Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 dgemv_((char *)"Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1
+ 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__
+ 1 + i__ * y_dim1], &c__1, (ftnlen)9); + 1 + i__ * y_dim1], &c__1, (ftnlen)9);
i__2 = *n - i__; i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
} }
/* L20: */ /* L20: */
} }
} }
return 0; return 0;
@ -528,5 +528,5 @@ f"> */
} /* dlabrd_ */ } /* dlabrd_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

112
lib/linalg/dlacn2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlacn2.f -- translated by f2c (version 20200916). /* fortran/dlacn2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -157,8 +157,8 @@ f"> */
/* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ /* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x, /* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase, integer *isave) integer *isgn, doublereal *est, integer *kase, integer *isave)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -172,8 +172,8 @@ f"> */
doublereal xs, temp; doublereal xs, temp;
extern doublereal dasum_(integer *, doublereal *, integer *); extern doublereal dasum_(integer *, doublereal *, integer *);
integer jlast; integer jlast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *);
doublereal altsgn, estold; doublereal altsgn, estold;
@ -209,22 +209,22 @@ f"> */
/* Function Body */ /* Function Body */
if (*kase == 0) { if (*kase == 0) {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1. / (doublereal) (*n); x[i__] = 1. / (doublereal) (*n);
/* L10: */ /* L10: */
} }
*kase = 1; *kase = 1;
isave[1] = 1; isave[1] = 1;
return 0; return 0;
} }
switch (isave[1]) { switch (isave[1]) {
case 1: goto L20; case 1: goto L20;
case 2: goto L40; case 2: goto L40;
case 3: goto L70; case 3: goto L70;
case 4: goto L110; case 4: goto L110;
case 5: goto L140; case 5: goto L140;
} }
/* ................ ENTRY (ISAVE( 1 ) = 1) */ /* ................ ENTRY (ISAVE( 1 ) = 1) */
@ -232,21 +232,21 @@ f"> */
L20: L20:
if (*n == 1) { if (*n == 1) {
v[1] = x[1]; v[1] = x[1];
*est = abs(v[1]); *est = abs(v[1]);
/* ... QUIT */ /* ... QUIT */
goto L150; goto L150;
} }
*est = dasum_(n, &x[1], &c__1); *est = dasum_(n, &x[1], &c__1);
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
if (x[i__] >= 0.) { if (x[i__] >= 0.) {
x[i__] = 1.; x[i__] = 1.;
} else { } else {
x[i__] = -1.; x[i__] = -1.;
} }
isgn[i__] = i_dnnt(&x[i__]); isgn[i__] = i_dnnt(&x[i__]);
/* L30: */ /* L30: */
} }
*kase = 2; *kase = 2;
@ -265,7 +265,7 @@ L40:
L50: L50:
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.; x[i__] = 0.;
/* L60: */ /* L60: */
} }
x[isave[2]] = 1.; x[isave[2]] = 1.;
@ -282,14 +282,14 @@ L70:
*est = dasum_(n, &v[1], &c__1); *est = dasum_(n, &v[1], &c__1);
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
if (x[i__] >= 0.) { if (x[i__] >= 0.) {
xs = 1.; xs = 1.;
} else { } else {
xs = -1.; xs = -1.;
} }
if (i_dnnt(&xs) != isgn[i__]) { if (i_dnnt(&xs) != isgn[i__]) {
goto L90; goto L90;
} }
/* L80: */ /* L80: */
} }
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ /* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
@ -298,17 +298,17 @@ L70:
L90: L90:
/* TEST FOR CYCLING. */ /* TEST FOR CYCLING. */
if (*est <= estold) { if (*est <= estold) {
goto L120; goto L120;
} }
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
if (x[i__] >= 0.) { if (x[i__] >= 0.) {
x[i__] = 1.; x[i__] = 1.;
} else { } else {
x[i__] = -1.; x[i__] = -1.;
} }
isgn[i__] = i_dnnt(&x[i__]); isgn[i__] = i_dnnt(&x[i__]);
/* L100: */ /* L100: */
} }
*kase = 2; *kase = 2;
@ -322,8 +322,8 @@ L110:
jlast = isave[2]; jlast = isave[2];
isave[2] = idamax_(n, &x[1], &c__1); isave[2] = idamax_(n, &x[1], &c__1);
if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) { if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) {
++isave[3]; ++isave[3];
goto L50; goto L50;
} }
/* ITERATION COMPLETE. FINAL STAGE. */ /* ITERATION COMPLETE. FINAL STAGE. */
@ -332,9 +332,9 @@ L120:
altsgn = 1.; altsgn = 1.;
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
1.); 1.);
altsgn = -altsgn; altsgn = -altsgn;
/* L130: */ /* L130: */
} }
*kase = 1; *kase = 1;
@ -347,8 +347,8 @@ L120:
L140: L140:
temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
if (temp > *est) { if (temp > *est) {
dcopy_(n, &x[1], &c__1, &v[1], &c__1); dcopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp; *est = temp;
} }
L150: L150:
@ -360,5 +360,5 @@ L150:
} /* dlacn2_ */ } /* dlacn2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

60
lib/linalg/dlacpy.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlacpy.f -- translated by f2c (version 20200916). /* fortran/dlacpy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -120,7 +120,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal * /* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal *
a, integer *lda, doublereal *b, integer *ldb, ftnlen uplo_len) a, integer *lda, doublereal *b, integer *ldb, ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
@ -159,35 +159,35 @@ f"> */
/* Function Body */ /* Function Body */
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m); i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) { for (i__ = j; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L50: */ /* L50: */
} }
/* L60: */ /* L60: */
} }
} }
return 0; return 0;
@ -196,5 +196,5 @@ f"> */
} /* dlacpy_ */ } /* dlacpy_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

80
lib/linalg/dladiv.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dladiv.f -- translated by f2c (version 20200916). /* fortran/dladiv.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -107,8 +107,8 @@ f"> */
/* > \ingroup doubleOTHERauxiliary */ /* > \ingroup doubleOTHERauxiliary */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__, /* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *d__, doublereal *p, doublereal *q) doublereal *d__, doublereal *p, doublereal *q)
{ {
/* System generated locals */ /* System generated locals */
doublereal d__1, d__2; doublereal d__1, d__2;
@ -116,8 +116,8 @@ f"> */
/* Local variables */ /* Local variables */
doublereal s, aa, ab, bb, cc, cd, dd, be, un, ov, eps; doublereal s, aa, ab, bb, cc, cd, dd, be, un, ov, eps;
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dladiv1_(doublereal *, doublereal *, extern /* Subroutine */ int dladiv1_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *); doublereal *, doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -157,30 +157,30 @@ f"> */
eps = dlamch_((char *)"Epsilon", (ftnlen)7); eps = dlamch_((char *)"Epsilon", (ftnlen)7);
be = 2. / (eps * eps); be = 2. / (eps * eps);
if (ab >= ov * .5) { if (ab >= ov * .5) {
aa *= .5; aa *= .5;
bb *= .5; bb *= .5;
s *= 2.; s *= 2.;
} }
if (cd >= ov * .5) { if (cd >= ov * .5) {
cc *= .5; cc *= .5;
dd *= .5; dd *= .5;
s *= .5; s *= .5;
} }
if (ab <= un * 2. / eps) { if (ab <= un * 2. / eps) {
aa *= be; aa *= be;
bb *= be; bb *= be;
s /= be; s /= be;
} }
if (cd <= un * 2. / eps) { if (cd <= un * 2. / eps) {
cc *= be; cc *= be;
dd *= be; dd *= be;
s *= be; s *= be;
} }
if (abs(*d__) <= abs(*c__)) { if (abs(*d__) <= abs(*c__)) {
dladiv1_(&aa, &bb, &cc, &dd, p, q); dladiv1_(&aa, &bb, &cc, &dd, p, q);
} else { } else {
dladiv1_(&bb, &aa, &dd, &cc, p, q); dladiv1_(&bb, &aa, &dd, &cc, p, q);
*q = -(*q); *q = -(*q);
} }
*p *= s; *p *= s;
*q *= s; *q *= s;
@ -192,12 +192,12 @@ f"> */
} /* dladiv_ */ } /* dladiv_ */
/* > \ingroup doubleOTHERauxiliary */ /* > \ingroup doubleOTHERauxiliary */
/* Subroutine */ int dladiv1_(doublereal *a, doublereal *b, doublereal *c__, /* Subroutine */ int dladiv1_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *d__, doublereal *p, doublereal *q) doublereal *d__, doublereal *p, doublereal *q)
{ {
doublereal r__, t; doublereal r__, t;
extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *, extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *); doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -230,8 +230,8 @@ f"> */
} /* dladiv1_ */ } /* dladiv1_ */
/* > \ingroup doubleOTHERauxiliary */ /* > \ingroup doubleOTHERauxiliary */
doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal
*d__, doublereal *r__, doublereal *t) *d__, doublereal *r__, doublereal *t)
{ {
/* System generated locals */ /* System generated locals */
doublereal ret_val; doublereal ret_val;
@ -256,14 +256,14 @@ doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal
/* .. Executable Statements .. */ /* .. Executable Statements .. */
if (*r__ != 0.) { if (*r__ != 0.) {
br = *b * *r__; br = *b * *r__;
if (br != 0.) { if (br != 0.) {
ret_val = (*a + br) * *t; ret_val = (*a + br) * *t;
} else { } else {
ret_val = *a * *t + *b * *t * *r__; ret_val = *a * *t + *b * *t * *r__;
} }
} else { } else {
ret_val = (*a + *d__ * (*b / *c__)) * *t; ret_val = (*a + *d__ * (*b / *c__)) * *t;
} }
return ret_val; return ret_val;
@ -273,5 +273,5 @@ doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal
} /* dladiv2_ */ } /* dladiv2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

50
lib/linalg/dlae2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlae2.f -- translated by f2c (version 20200916). /* fortran/dlae2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -118,8 +118,8 @@ extern "C" {
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__, /* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *rt1, doublereal *rt2) doublereal *rt1, doublereal *rt2)
{ {
/* System generated locals */ /* System generated locals */
doublereal d__1; doublereal d__1;
@ -156,48 +156,48 @@ extern "C" {
tb = *b + *b; tb = *b + *b;
ab = abs(tb); ab = abs(tb);
if (abs(*a) > abs(*c__)) { if (abs(*a) > abs(*c__)) {
acmx = *a; acmx = *a;
acmn = *c__; acmn = *c__;
} else { } else {
acmx = *c__; acmx = *c__;
acmn = *a; acmn = *a;
} }
if (adf > ab) { if (adf > ab) {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = ab / adf; d__1 = ab / adf;
rt = adf * sqrt(d__1 * d__1 + 1.); rt = adf * sqrt(d__1 * d__1 + 1.);
} else if (adf < ab) { } else if (adf < ab) {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = adf / ab; d__1 = adf / ab;
rt = ab * sqrt(d__1 * d__1 + 1.); rt = ab * sqrt(d__1 * d__1 + 1.);
} else { } else {
/* Includes case AB=ADF=0 */ /* Includes case AB=ADF=0 */
rt = ab * sqrt(2.); rt = ab * sqrt(2.);
} }
if (sm < 0.) { if (sm < 0.) {
*rt1 = (sm - rt) * .5; *rt1 = (sm - rt) * .5;
/* Order of execution important. */ /* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */ /* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */ /* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else if (sm > 0.) { } else if (sm > 0.) {
*rt1 = (sm + rt) * .5; *rt1 = (sm + rt) * .5;
/* Order of execution important. */ /* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */ /* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */ /* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else { } else {
/* Includes case RT1 = RT2 = 0 */ /* Includes case RT1 = RT2 = 0 */
*rt1 = rt * .5; *rt1 = rt * .5;
*rt2 = rt * -.5; *rt2 = rt * -.5;
} }
return 0; return 0;
@ -206,5 +206,5 @@ extern "C" {
} /* dlae2_ */ } /* dlae2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

336
lib/linalg/dlaed0.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed0.f -- translated by f2c (version 20200916). /* fortran/dlaed0.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -24,7 +24,7 @@ static doublereal c_b23 = 1.;
static doublereal c_b24 = 0.; static doublereal c_b24 = 0.;
static integer c__1 = 1; static integer c__1 = 1;
/* > \brief \b DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced /* > \brief \b DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced
symmetric tridiagonal matrix using the divide and conquer method. */ symmetric tridiagonal matrix using the divide and conquer method. */
/* =========== DOCUMENTATION =========== */ /* =========== DOCUMENTATION =========== */
@ -197,10 +197,10 @@ f"> */
/* > at Berkeley, USA */ /* > at Berkeley, USA */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n, /* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n,
doublereal *d__, doublereal *e, doublereal *q, integer *ldq, doublereal *d__, doublereal *e, doublereal *q, integer *ldq,
doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork, doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork,
integer *info) integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
@ -214,33 +214,33 @@ f"> */
integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2; integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2;
doublereal temp; doublereal temp;
integer curr; integer curr;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
integer iperm; integer iperm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
integer indxq, iwrem; integer indxq, iwrem;
extern /* Subroutine */ int dlaed1_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dlaed1_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *); integer *, integer *);
integer iqptr; integer iqptr;
extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *, extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *, doublereal integer *, integer *, integer *, integer *, integer *, doublereal
*, doublereal *, integer *, integer *); *, doublereal *, integer *, integer *);
integer tlvls; integer tlvls;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen); doublereal *, integer *, doublereal *, integer *, ftnlen);
integer igivcl; integer igivcl;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer igivnm, submat, curprb, subpbs, igivpt; integer igivnm, submat, curprb, subpbs, igivpt;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
ftnlen); ftnlen);
integer curlvl, matsiz, iprmpt, smlsiz; integer curlvl, matsiz, iprmpt, smlsiz;
@ -285,30 +285,30 @@ f"> */
*info = 0; *info = 0;
if (*icompq < 0 || *icompq > 2) { if (*icompq < 0 || *icompq > 2) {
*info = -1; *info = -1;
} else if (*icompq == 1 && *qsiz < max(0,*n)) { } else if (*icompq == 1 && *qsiz < max(0,*n)) {
*info = -2; *info = -2;
} else if (*n < 0) { } else if (*n < 0) {
*info = -3; *info = -3;
} else if (*ldq < max(1,*n)) { } else if (*ldq < max(1,*n)) {
*info = -7; *info = -7;
} else if (*ldqs < max(1,*n)) { } else if (*ldqs < max(1,*n)) {
*info = -9; *info = -9;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAED0", &i__1, (ftnlen)6); xerbla_((char *)"DLAED0", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
smlsiz = ilaenv_(&c__9, (char *)"DLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( smlsiz = ilaenv_(&c__9, (char *)"DLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
/* Determine the size and placement of the submatrices, and save in */ /* Determine the size and placement of the submatrices, and save in */
/* the leading elements of IWORK. */ /* the leading elements of IWORK. */
@ -318,18 +318,18 @@ f"> */
tlvls = 0; tlvls = 0;
L10: L10:
if (iwork[subpbs] > smlsiz) { if (iwork[subpbs] > smlsiz) {
for (j = subpbs; j >= 1; --j) { for (j = subpbs; j >= 1; --j) {
iwork[j * 2] = (iwork[j] + 1) / 2; iwork[j * 2] = (iwork[j] + 1) / 2;
iwork[(j << 1) - 1] = iwork[j] / 2; iwork[(j << 1) - 1] = iwork[j] / 2;
/* L20: */ /* L20: */
} }
++tlvls; ++tlvls;
subpbs <<= 1; subpbs <<= 1;
goto L10; goto L10;
} }
i__1 = subpbs; i__1 = subpbs;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
iwork[j] += iwork[j - 1]; iwork[j] += iwork[j - 1];
/* L30: */ /* L30: */
} }
@ -339,10 +339,10 @@ L10:
spm1 = subpbs - 1; spm1 = subpbs - 1;
i__1 = spm1; i__1 = spm1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
submat = iwork[i__] + 1; submat = iwork[i__] + 1;
smm1 = submat - 1; smm1 = submat - 1;
d__[smm1] -= (d__1 = e[smm1], abs(d__1)); d__[smm1] -= (d__1 = e[smm1], abs(d__1));
d__[submat] -= (d__1 = e[smm1], abs(d__1)); d__[submat] -= (d__1 = e[smm1], abs(d__1));
/* L40: */ /* L40: */
} }
@ -352,35 +352,35 @@ L10:
/* Set up workspaces for eigenvalues only/accumulate new vectors */ /* Set up workspaces for eigenvalues only/accumulate new vectors */
/* routine */ /* routine */
temp = log((doublereal) (*n)) / log(2.); temp = log((doublereal) (*n)) / log(2.);
lgn = (integer) temp; lgn = (integer) temp;
if (pow_ii(&c__2, &lgn) < *n) { if (pow_ii(&c__2, &lgn) < *n) {
++lgn; ++lgn;
} }
if (pow_ii(&c__2, &lgn) < *n) { if (pow_ii(&c__2, &lgn) < *n) {
++lgn; ++lgn;
} }
iprmpt = indxq + *n + 1; iprmpt = indxq + *n + 1;
iperm = iprmpt + *n * lgn; iperm = iprmpt + *n * lgn;
iqptr = iperm + *n * lgn; iqptr = iperm + *n * lgn;
igivpt = iqptr + *n + 2; igivpt = iqptr + *n + 2;
igivcl = igivpt + *n * lgn; igivcl = igivpt + *n * lgn;
igivnm = 1; igivnm = 1;
iq = igivnm + (*n << 1) * lgn; iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */ /* Computing 2nd power */
i__1 = *n; i__1 = *n;
iwrem = iq + i__1 * i__1 + 1; iwrem = iq + i__1 * i__1 + 1;
/* Initialize pointers */ /* Initialize pointers */
i__1 = subpbs; i__1 = subpbs;
for (i__ = 0; i__ <= i__1; ++i__) { for (i__ = 0; i__ <= i__1; ++i__) {
iwork[iprmpt + i__] = 1; iwork[iprmpt + i__] = 1;
iwork[igivpt + i__] = 1; iwork[igivpt + i__] = 1;
/* L50: */ /* L50: */
} }
iwork[iqptr] = 1; iwork[iqptr] = 1;
} }
/* Solve each submatrix eigenproblem at the bottom of the divide and */ /* Solve each submatrix eigenproblem at the bottom of the divide and */
@ -389,43 +389,43 @@ L10:
curr = 0; curr = 0;
i__1 = spm1; i__1 = spm1;
for (i__ = 0; i__ <= i__1; ++i__) { for (i__ = 0; i__ <= i__1; ++i__) {
if (i__ == 0) { if (i__ == 0) {
submat = 1; submat = 1;
matsiz = iwork[1]; matsiz = iwork[1];
} else { } else {
submat = iwork[i__] + 1; submat = iwork[i__] + 1;
matsiz = iwork[i__ + 1] - iwork[i__]; matsiz = iwork[i__ + 1] - iwork[i__];
} }
if (*icompq == 2) { if (*icompq == 2) {
dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &q[submat + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &q[submat +
submat * q_dim1], ldq, &work[1], info, (ftnlen)1); submat * q_dim1], ldq, &work[1], info, (ftnlen)1);
if (*info != 0) { if (*info != 0) {
goto L130; goto L130;
} }
} else { } else {
dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 +
iwork[iqptr + curr]], &matsiz, &work[1], info, (ftnlen)1); iwork[iqptr + curr]], &matsiz, &work[1], info, (ftnlen)1);
if (*info != 0) { if (*info != 0) {
goto L130; goto L130;
} }
if (*icompq == 1) { if (*icompq == 1) {
dgemm_((char *)"N", (char *)"N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * dgemm_((char *)"N", (char *)"N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat *
q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]], q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]],
&matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1], &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1],
ldqs, (ftnlen)1, (ftnlen)1); ldqs, (ftnlen)1, (ftnlen)1);
} }
/* Computing 2nd power */ /* Computing 2nd power */
i__2 = matsiz; i__2 = matsiz;
iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
++curr; ++curr;
} }
k = 1; k = 1;
i__2 = iwork[i__ + 1]; i__2 = iwork[i__ + 1];
for (j = submat; j <= i__2; ++j) { for (j = submat; j <= i__2; ++j) {
iwork[indxq + j] = k; iwork[indxq + j] = k;
++k; ++k;
/* L60: */ /* L60: */
} }
/* L70: */ /* L70: */
} }
@ -437,20 +437,20 @@ L10:
curlvl = 1; curlvl = 1;
L80: L80:
if (subpbs > 1) { if (subpbs > 1) {
spm2 = subpbs - 2; spm2 = subpbs - 2;
i__1 = spm2; i__1 = spm2;
for (i__ = 0; i__ <= i__1; i__ += 2) { for (i__ = 0; i__ <= i__1; i__ += 2) {
if (i__ == 0) { if (i__ == 0) {
submat = 1; submat = 1;
matsiz = iwork[2]; matsiz = iwork[2];
msd2 = iwork[1]; msd2 = iwork[1];
curprb = 0; curprb = 0;
} else { } else {
submat = iwork[i__] + 1; submat = iwork[i__] + 1;
matsiz = iwork[i__ + 2] - iwork[i__]; matsiz = iwork[i__ + 2] - iwork[i__];
msd2 = matsiz / 2; msd2 = matsiz / 2;
++curprb; ++curprb;
} }
/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */ /* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
/* into an eigensystem of size MATSIZ. */ /* into an eigensystem of size MATSIZ. */
@ -460,27 +460,27 @@ L80:
/* and eigenvectors of a full symmetric matrix (which was reduced to */ /* and eigenvectors of a full symmetric matrix (which was reduced to */
/* tridiagonal form) are desired. */ /* tridiagonal form) are desired. */
if (*icompq == 2) { if (*icompq == 2) {
dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1],
ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], &
msd2, &work[1], &iwork[subpbs + 1], info); msd2, &work[1], &iwork[subpbs + 1], info);
} else { } else {
dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[ dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[
submat], &qstore[submat * qstore_dim1 + 1], ldqs, & submat], &qstore[submat * qstore_dim1 + 1], ldqs, &
iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, & iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &
work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm] work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm]
, &iwork[igivpt], &iwork[igivcl], &work[igivnm], & , &iwork[igivpt], &iwork[igivcl], &work[igivnm], &
work[iwrem], &iwork[subpbs + 1], info); work[iwrem], &iwork[subpbs + 1], info);
} }
if (*info != 0) { if (*info != 0) {
goto L130; goto L130;
} }
iwork[i__ / 2 + 1] = iwork[i__ + 2]; iwork[i__ / 2 + 1] = iwork[i__ + 2];
/* L90: */ /* L90: */
} }
subpbs /= 2; subpbs /= 2;
++curlvl; ++curlvl;
goto L80; goto L80;
} }
/* end while */ /* end while */
@ -489,33 +489,33 @@ L80:
/* merge step. */ /* merge step. */
if (*icompq == 1) { if (*icompq == 1) {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__]; j = iwork[indxq + i__];
work[i__] = d__[j]; work[i__] = d__[j];
dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1
+ 1], &c__1); + 1], &c__1);
/* L100: */ /* L100: */
} }
dcopy_(n, &work[1], &c__1, &d__[1], &c__1); dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
} else if (*icompq == 2) { } else if (*icompq == 2) {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__]; j = iwork[indxq + i__];
work[i__] = d__[j]; work[i__] = d__[j];
dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1);
/* L110: */ /* L110: */
} }
dcopy_(n, &work[1], &c__1, &d__[1], &c__1); dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
dlacpy_((char *)"A", n, n, &work[*n + 1], n, &q[q_offset], ldq, (ftnlen)1); dlacpy_((char *)"A", n, n, &work[*n + 1], n, &q[q_offset], ldq, (ftnlen)1);
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__]; j = iwork[indxq + i__];
work[i__] = d__[j]; work[i__] = d__[j];
/* L120: */ /* L120: */
} }
dcopy_(n, &work[1], &c__1, &d__[1], &c__1); dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
} }
goto L140; goto L140;
@ -530,5 +530,5 @@ L140:
} /* dlaed0_ */ } /* dlaed0_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

102
lib/linalg/dlaed1.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed1.f -- translated by f2c (version 20200916). /* fortran/dlaed1.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -184,29 +184,29 @@ f"> */
/* > Modified by Francoise Tisseur, University of Tennessee */ /* > Modified by Francoise Tisseur, University of Tennessee */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q, /* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q,
integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt,
doublereal *work, integer *iwork, integer *info) doublereal *work, integer *iwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer q_dim1, q_offset, i__1, i__2; integer q_dim1, q_offset, i__1, i__2;
/* Local variables */ /* Local variables */
integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc; integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
integer indxp; integer indxp;
extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *, extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *, integer *), dlaed3_(integer *, integer *, integer *, integer *, integer *), dlaed3_(integer *,
integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *); doublereal *, doublereal *, integer *);
integer idlmda; integer idlmda;
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *, integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen); ftnlen);
integer coltyp; integer coltyp;
@ -244,26 +244,26 @@ f"> */
*info = 0; *info = 0;
if (*n < 0) { if (*n < 0) {
*info = -1; *info = -1;
} else if (*ldq < max(1,*n)) { } else if (*ldq < max(1,*n)) {
*info = -4; *info = -4;
} else /* if(complicated condition) */ { } else /* if(complicated condition) */ {
/* Computing MIN */ /* Computing MIN */
i__1 = 1, i__2 = *n / 2; i__1 = 1, i__2 = *n / 2;
if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) { if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) {
*info = -7; *info = -7;
} }
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAED1", &i__1, (ftnlen)6); xerbla_((char *)"DLAED1", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
/* The following values are integer pointers which indicate */ /* The following values are integer pointers which indicate */
@ -292,36 +292,36 @@ f"> */
/* Deflate eigenvalues. */ /* Deflate eigenvalues. */
dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[ dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[
iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[ iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[
indxc], &iwork[indxp], &iwork[coltyp], info); indxc], &iwork[indxp], &iwork[coltyp], info);
if (*info != 0) { if (*info != 0) {
goto L20; goto L20;
} }
/* Solve Secular Equation. */ /* Solve Secular Equation. */
if (k != 0) { if (k != 0) {
is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp +
1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2;
dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda],
&work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[ &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[
is], info); is], info);
if (*info != 0) { if (*info != 0) {
goto L20; goto L20;
} }
/* Prepare the INDXQ sorting permutation. */ /* Prepare the INDXQ sorting permutation. */
n1 = k; n1 = k;
n2 = *n - k; n2 = *n - k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
indxq[i__] = i__; indxq[i__] = i__;
/* L10: */ /* L10: */
} }
} }
L20: L20:
@ -332,5 +332,5 @@ L20:
} /* dlaed1_ */ } /* dlaed1_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

294
lib/linalg/dlaed2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed2.f -- translated by f2c (version 20200916). /* fortran/dlaed2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -234,10 +234,10 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal * /* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal *
d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho,
doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2, doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2,
integer *indx, integer *indxc, integer *indxp, integer *coltyp, integer *indx, integer *indxc, integer *indxp, integer *coltyp,
integer *info) integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer q_dim1, q_offset, i__1, i__2; integer q_dim1, q_offset, i__1, i__2;
@ -253,19 +253,19 @@ f"> */
integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1; integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
doublereal eps, tau, tol; doublereal eps, tau, tol;
integer psm[4], imax, jmax; integer psm[4], imax, jmax;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *); doublereal *, integer *, doublereal *, doublereal *);
integer ctot[4]; integer ctot[4];
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dcopy_(integer *, doublereal *, integer *, doublereal integer *), dcopy_(integer *, doublereal *, integer *, doublereal
*, integer *); *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen); ftnlen);
extern integer idamax_(integer *, doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *, integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -314,33 +314,33 @@ f"> */
*info = 0; *info = 0;
if (*n < 0) { if (*n < 0) {
*info = -2; *info = -2;
} else if (*ldq < max(1,*n)) { } else if (*ldq < max(1,*n)) {
*info = -6; *info = -6;
} else /* if(complicated condition) */ { } else /* if(complicated condition) */ {
/* Computing MIN */ /* Computing MIN */
i__1 = 1, i__2 = *n / 2; i__1 = 1, i__2 = *n / 2;
if (min(i__1,i__2) > *n1 || *n / 2 < *n1) { if (min(i__1,i__2) > *n1 || *n / 2 < *n1) {
*info = -3; *info = -3;
} }
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAED2", &i__1, (ftnlen)6); xerbla_((char *)"DLAED2", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
n2 = *n - *n1; n2 = *n - *n1;
n1p1 = *n1 + 1; n1p1 = *n1 + 1;
if (*rho < 0.) { if (*rho < 0.) {
dscal_(&n2, &c_b3, &z__[n1p1], &c__1); dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
} }
/* Normalize z so that norm(z) = 1. Since z is the concatenation of */ /* Normalize z so that norm(z) = 1. Since z is the concatenation of */
@ -357,7 +357,7 @@ f"> */
i__1 = *n; i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) { for (i__ = n1p1; i__ <= i__1; ++i__) {
indxq[i__] += *n1; indxq[i__] += *n1;
/* L10: */ /* L10: */
} }
@ -365,13 +365,13 @@ f"> */
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]]; dlamda[i__] = d__[indxq[i__]];
/* L20: */ /* L20: */
} }
dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]); dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
indx[i__] = indxq[indxc[i__]]; indx[i__] = indxq[indxc[i__]];
/* L30: */ /* L30: */
} }
@ -382,7 +382,7 @@ f"> */
eps = dlamch_((char *)"Epsilon", (ftnlen)7); eps = dlamch_((char *)"Epsilon", (ftnlen)7);
/* Computing MAX */ /* Computing MAX */
d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2)) d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2))
; ;
tol = eps * 8. * max(d__3,d__4); tol = eps * 8. * max(d__3,d__4);
/* If the rank-1 modifier is small enough, no more needs to be done */ /* If the rank-1 modifier is small enough, no more needs to be done */
@ -390,19 +390,19 @@ f"> */
/* elements in D. */ /* elements in D. */
if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
*k = 0; *k = 0;
iq2 = 1; iq2 = 1;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__ = indx[j]; i__ = indx[j];
dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
dlamda[j] = d__[i__]; dlamda[j] = d__[i__];
iq2 += *n; iq2 += *n;
/* L40: */ /* L40: */
} }
dlacpy_((char *)"A", n, n, &q2[1], n, &q[q_offset], ldq, (ftnlen)1); dlacpy_((char *)"A", n, n, &q2[1], n, &q[q_offset], ldq, (ftnlen)1);
dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1); dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
goto L190; goto L190;
} }
/* If there are multiple eigenvalues then the problem deflates. Here */ /* If there are multiple eigenvalues then the problem deflates. Here */
@ -413,12 +413,12 @@ f"> */
i__1 = *n1; i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
coltyp[i__] = 1; coltyp[i__] = 1;
/* L50: */ /* L50: */
} }
i__1 = *n; i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) { for (i__ = n1p1; i__ <= i__1; ++i__) {
coltyp[i__] = 3; coltyp[i__] = 3;
/* L60: */ /* L60: */
} }
@ -427,96 +427,96 @@ f"> */
k2 = *n + 1; k2 = *n + 1;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
nj = indx[j]; nj = indx[j];
if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
/* Deflate due to small z component. */ /* Deflate due to small z component. */
--k2; --k2;
coltyp[nj] = 4; coltyp[nj] = 4;
indxp[k2] = nj; indxp[k2] = nj;
if (j == *n) { if (j == *n) {
goto L100; goto L100;
} }
} else { } else {
pj = nj; pj = nj;
goto L80; goto L80;
} }
/* L70: */ /* L70: */
} }
L80: L80:
++j; ++j;
nj = indx[j]; nj = indx[j];
if (j > *n) { if (j > *n) {
goto L100; goto L100;
} }
if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
/* Deflate due to small z component. */ /* Deflate due to small z component. */
--k2; --k2;
coltyp[nj] = 4; coltyp[nj] = 4;
indxp[k2] = nj; indxp[k2] = nj;
} else { } else {
/* Check if eigenvalues are close enough to allow deflation. */ /* Check if eigenvalues are close enough to allow deflation. */
s = z__[pj]; s = z__[pj];
c__ = z__[nj]; c__ = z__[nj];
/* Find sqrt(a**2+b**2) without overflow or */ /* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */ /* destructive underflow. */
tau = dlapy2_(&c__, &s); tau = dlapy2_(&c__, &s);
t = d__[nj] - d__[pj]; t = d__[nj] - d__[pj];
c__ /= tau; c__ /= tau;
s = -s / tau; s = -s / tau;
if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
/* Deflation is possible. */ /* Deflation is possible. */
z__[nj] = tau; z__[nj] = tau;
z__[pj] = 0.; z__[pj] = 0.;
if (coltyp[nj] != coltyp[pj]) { if (coltyp[nj] != coltyp[pj]) {
coltyp[nj] = 2; coltyp[nj] = 2;
} }
coltyp[pj] = 4; coltyp[pj] = 4;
drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
c__, &s); c__, &s);
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = c__; d__1 = c__;
/* Computing 2nd power */ /* Computing 2nd power */
d__2 = s; d__2 = s;
t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = s; d__1 = s;
/* Computing 2nd power */ /* Computing 2nd power */
d__2 = c__; d__2 = c__;
d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
d__[pj] = t; d__[pj] = t;
--k2; --k2;
i__ = 1; i__ = 1;
L90: L90:
if (k2 + i__ <= *n) { if (k2 + i__ <= *n) {
if (d__[pj] < d__[indxp[k2 + i__]]) { if (d__[pj] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__]; indxp[k2 + i__ - 1] = indxp[k2 + i__];
indxp[k2 + i__] = pj; indxp[k2 + i__] = pj;
++i__; ++i__;
goto L90; goto L90;
} else { } else {
indxp[k2 + i__ - 1] = pj; indxp[k2 + i__ - 1] = pj;
} }
} else { } else {
indxp[k2 + i__ - 1] = pj; indxp[k2 + i__ - 1] = pj;
} }
pj = nj; pj = nj;
} else { } else {
++(*k); ++(*k);
dlamda[*k] = d__[pj]; dlamda[*k] = d__[pj];
w[*k] = z__[pj]; w[*k] = z__[pj];
indxp[*k] = pj; indxp[*k] = pj;
pj = nj; pj = nj;
} }
} }
goto L80; goto L80;
L100: L100:
@ -534,13 +534,13 @@ L100:
/* empty). */ /* empty). */
for (j = 1; j <= 4; ++j) { for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0; ctot[j - 1] = 0;
/* L110: */ /* L110: */
} }
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
ct = coltyp[j]; ct = coltyp[j];
++ctot[ct - 1]; ++ctot[ct - 1];
/* L120: */ /* L120: */
} }
@ -558,11 +558,11 @@ L100:
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
js = indxp[j]; js = indxp[j];
ct = coltyp[js]; ct = coltyp[js];
indx[psm[ct - 1]] = js; indx[psm[ct - 1]] = js;
indxc[psm[ct - 1]] = j; indxc[psm[ct - 1]] = j;
++psm[ct - 1]; ++psm[ct - 1];
/* L130: */ /* L130: */
} }
@ -576,44 +576,44 @@ L100:
iq2 = (ctot[0] + ctot[1]) * *n1 + 1; iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
i__1 = ctot[0]; i__1 = ctot[0];
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
js = indx[i__]; js = indx[i__];
dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
z__[i__] = d__[js]; z__[i__] = d__[js];
++i__; ++i__;
iq1 += *n1; iq1 += *n1;
/* L140: */ /* L140: */
} }
i__1 = ctot[1]; i__1 = ctot[1];
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
js = indx[i__]; js = indx[i__];
dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js]; z__[i__] = d__[js];
++i__; ++i__;
iq1 += *n1; iq1 += *n1;
iq2 += n2; iq2 += n2;
/* L150: */ /* L150: */
} }
i__1 = ctot[2]; i__1 = ctot[2];
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
js = indx[i__]; js = indx[i__];
dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js]; z__[i__] = d__[js];
++i__; ++i__;
iq2 += n2; iq2 += n2;
/* L160: */ /* L160: */
} }
iq1 = iq2; iq1 = iq2;
i__1 = ctot[3]; i__1 = ctot[3];
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
js = indx[i__]; js = indx[i__];
dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1); dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
iq2 += *n; iq2 += *n;
z__[i__] = d__[js]; z__[i__] = d__[js];
++i__; ++i__;
/* L170: */ /* L170: */
} }
@ -621,16 +621,16 @@ L100:
/* into the last N - K slots of D and Q respectively. */ /* into the last N - K slots of D and Q respectively. */
if (*k < *n) { if (*k < *n) {
dlacpy_((char *)"A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq, dlacpy_((char *)"A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq,
(ftnlen)1); (ftnlen)1);
i__1 = *n - *k; i__1 = *n - *k;
dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
} }
/* Copy CTOT into COLTYP for referencing in DLAED3. */ /* Copy CTOT into COLTYP for referencing in DLAED3. */
for (j = 1; j <= 4; ++j) { for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1]; coltyp[j] = ctot[j - 1];
/* L180: */ /* L180: */
} }
@ -642,5 +642,5 @@ L190:
} /* dlaed2_ */ } /* dlaed2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

148
lib/linalg/dlaed3.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed3.f -- translated by f2c (version 20200916). /* fortran/dlaed3.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -208,9 +208,9 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal * /* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal *
d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda,
doublereal *q2, integer *indx, integer *ctot, doublereal *w, doublereal *q2, integer *indx, integer *ctot, doublereal *w,
doublereal *s, integer *info) doublereal *s, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer q_dim1, q_offset, i__1, i__2; integer q_dim1, q_offset, i__1, i__2;
@ -223,18 +223,18 @@ f"> */
integer i__, j, n2, n12, ii, n23, iq2; integer i__, j, n2, n12, ii, n23, iq2;
doublereal temp; doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *); extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer dcopy_(integer *, doublereal *, integer *, doublereal *, integer
*), dlaed4_(integer *, integer *, doublereal *, doublereal *, *), dlaed4_(integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *); doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *); extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen), doublereal *, integer *, doublereal *, integer *, ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen), xerbla_(char *, integer *, doublereal *, integer *, ftnlen), xerbla_(char *, integer *,
ftnlen); ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -278,22 +278,22 @@ f"> */
*info = 0; *info = 0;
if (*k < 0) { if (*k < 0) {
*info = -1; *info = -1;
} else if (*n < *k) { } else if (*n < *k) {
*info = -2; *info = -2;
} else if (*ldq < max(1,*n)) { } else if (*ldq < max(1,*n)) {
*info = -6; *info = -6;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAED3", &i__1, (ftnlen)6); xerbla_((char *)"DLAED3", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*k == 0) { if (*k == 0) {
return 0; return 0;
} }
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
@ -315,38 +315,38 @@ f"> */
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */ /* L10: */
} }
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
info); info);
/* If the zero finder fails, the computation is terminated. */ /* If the zero finder fails, the computation is terminated. */
if (*info != 0) { if (*info != 0) {
goto L120; goto L120;
} }
/* L20: */ /* L20: */
} }
if (*k == 1) { if (*k == 1) {
goto L110; goto L110;
} }
if (*k == 2) { if (*k == 2) {
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
w[1] = q[j * q_dim1 + 1]; w[1] = q[j * q_dim1 + 1];
w[2] = q[j * q_dim1 + 2]; w[2] = q[j * q_dim1 + 2];
ii = indx[1]; ii = indx[1];
q[j * q_dim1 + 1] = w[ii]; q[j * q_dim1 + 1] = w[ii];
ii = indx[2]; ii = indx[2];
q[j * q_dim1 + 2] = w[ii]; q[j * q_dim1 + 2] = w[ii];
/* L30: */ /* L30: */
} }
goto L110; goto L110;
} }
/* Compute updated W. */ /* Compute updated W. */
@ -359,22 +359,22 @@ f"> */
dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L40: */ /* L40: */
} }
i__2 = *k; i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L50: */ /* L50: */
} }
/* L60: */ /* L60: */
} }
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = sqrt(-w[i__]); d__1 = sqrt(-w[i__]);
w[i__] = d_sign(&d__1, &s[i__]); w[i__] = d_sign(&d__1, &s[i__]);
/* L70: */ /* L70: */
} }
@ -382,18 +382,18 @@ f"> */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *k; i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
s[i__] = w[i__] / q[i__ + j * q_dim1]; s[i__] = w[i__] / q[i__ + j * q_dim1];
/* L80: */ /* L80: */
} }
temp = dnrm2_(k, &s[1], &c__1); temp = dnrm2_(k, &s[1], &c__1);
i__2 = *k; i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
ii = indx[i__]; ii = indx[i__];
q[i__ + j * q_dim1] = s[ii] / temp; q[i__ + j * q_dim1] = s[ii] / temp;
/* L90: */ /* L90: */
} }
/* L100: */ /* L100: */
} }
@ -406,22 +406,22 @@ L110:
n23 = ctot[2] + ctot[3]; n23 = ctot[2] + ctot[3];
dlacpy_((char *)"A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23, (ftnlen) dlacpy_((char *)"A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23, (ftnlen)
1); 1);
iq2 = *n1 * n12 + 1; iq2 = *n1 * n12 + 1;
if (n23 != 0) { if (n23 != 0) {
dgemm_((char *)"N", (char *)"N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & dgemm_((char *)"N", (char *)"N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
c_b23, &q[*n1 + 1 + q_dim1], ldq, (ftnlen)1, (ftnlen)1); c_b23, &q[*n1 + 1 + q_dim1], ldq, (ftnlen)1, (ftnlen)1);
} else { } else {
dlaset_((char *)"A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq, ( dlaset_((char *)"A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq, (
ftnlen)1); ftnlen)1);
} }
dlacpy_((char *)"A", &n12, k, &q[q_offset], ldq, &s[1], &n12, (ftnlen)1); dlacpy_((char *)"A", &n12, k, &q[q_offset], ldq, &s[1], &n12, (ftnlen)1);
if (n12 != 0) { if (n12 != 0) {
dgemm_((char *)"N", (char *)"N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, dgemm_((char *)"N", (char *)"N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
&q[q_offset], ldq, (ftnlen)1, (ftnlen)1); &q[q_offset], ldq, (ftnlen)1, (ftnlen)1);
} else { } else {
dlaset_((char *)"A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq, (ftnlen)1); dlaset_((char *)"A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq, (ftnlen)1);
} }
@ -433,5 +433,5 @@ L120:
} /* dlaed3_ */ } /* dlaed3_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

1150
lib/linalg/dlaed4.cpp
View File

File diff suppressed because it is too large Load Diff

92
lib/linalg/dlaed5.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed5.f -- translated by f2c (version 20200916). /* fortran/dlaed5.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -124,8 +124,8 @@ f"> */
/* > at Berkeley, USA */ /* > at Berkeley, USA */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, /* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__,
doublereal *delta, doublereal *rho, doublereal *dlam) doublereal *delta, doublereal *rho, doublereal *dlam)
{ {
/* System generated locals */ /* System generated locals */
doublereal d__1; doublereal d__1;
@ -164,49 +164,49 @@ f"> */
/* Function Body */ /* Function Body */
del = d__[2] - d__[1]; del = d__[2] - d__[1];
if (*i__ == 1) { if (*i__ == 1) {
w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.; w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.;
if (w > 0.) { if (w > 0.) {
b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[1] * z__[1] * del; c__ = *rho * z__[1] * z__[1] * del;
/* B > ZERO, always */ /* B > ZERO, always */
tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
*dlam = d__[1] + tau; *dlam = d__[1] + tau;
delta[1] = -z__[1] / tau; delta[1] = -z__[1] / tau;
delta[2] = z__[2] / (del - tau); delta[2] = z__[2] / (del - tau);
} else { } else {
b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * del; c__ = *rho * z__[2] * z__[2] * del;
if (b > 0.) { if (b > 0.) {
tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.));
} else { } else {
tau = (b - sqrt(b * b + c__ * 4.)) / 2.; tau = (b - sqrt(b * b + c__ * 4.)) / 2.;
} }
*dlam = d__[2] + tau; *dlam = d__[2] + tau;
delta[1] = -z__[1] / (del + tau); delta[1] = -z__[1] / (del + tau);
delta[2] = -z__[2] / tau; delta[2] = -z__[2] / tau;
} }
temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
delta[1] /= temp; delta[1] /= temp;
delta[2] /= temp; delta[2] /= temp;
} else { } else {
/* Now I=2 */ /* Now I=2 */
b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * del; c__ = *rho * z__[2] * z__[2] * del;
if (b > 0.) { if (b > 0.) {
tau = (b + sqrt(b * b + c__ * 4.)) / 2.; tau = (b + sqrt(b * b + c__ * 4.)) / 2.;
} else { } else {
tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.));
} }
*dlam = d__[2] + tau; *dlam = d__[2] + tau;
delta[1] = -z__[1] / (del + tau); delta[1] = -z__[1] / (del + tau);
delta[2] = -z__[2] / tau; delta[2] = -z__[2] / tau;
temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
delta[1] /= temp; delta[1] /= temp;
delta[2] /= temp; delta[2] /= temp;
} }
return 0; return 0;
@ -215,5 +215,5 @@ f"> */
} /* dlaed5_ */ } /* dlaed5_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

312
lib/linalg/dlaed6.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed6.f -- translated by f2c (version 20200916). /* fortran/dlaed6.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -157,8 +157,8 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal * /* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal *
rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal * rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal *
tau, integer *info) tau, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -211,65 +211,65 @@ f"> */
*info = 0; *info = 0;
if (*orgati) { if (*orgati) {
lbd = d__[2]; lbd = d__[2];
ubd = d__[3]; ubd = d__[3];
} else { } else {
lbd = d__[1]; lbd = d__[1];
ubd = d__[2]; ubd = d__[2];
} }
if (*finit < 0.) { if (*finit < 0.) {
lbd = 0.; lbd = 0.;
} else { } else {
ubd = 0.; ubd = 0.;
} }
niter = 1; niter = 1;
*tau = 0.; *tau = 0.;
if (*kniter == 2) { if (*kniter == 2) {
if (*orgati) { if (*orgati) {
temp = (d__[3] - d__[2]) / 2.; temp = (d__[3] - d__[2]) / 2.;
c__ = *rho + z__[1] / (d__[1] - d__[2] - temp); c__ = *rho + z__[1] / (d__[1] - d__[2] - temp);
a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3]; a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3];
b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2]; b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2];
} else { } else {
temp = (d__[1] - d__[2]) / 2.; temp = (d__[1] - d__[2]) / 2.;
c__ = *rho + z__[3] / (d__[3] - d__[2] - temp); c__ = *rho + z__[3] / (d__[3] - d__[2] - temp);
a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2]; a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2];
b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1]; b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1];
} }
/* Computing MAX */ /* Computing MAX */
d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__); d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__);
temp = max(d__1,d__2); temp = max(d__1,d__2);
a /= temp; a /= temp;
b /= temp; b /= temp;
c__ /= temp; c__ /= temp;
if (c__ == 0.) { if (c__ == 0.) {
*tau = b / a; *tau = b / a;
} else if (a <= 0.) { } else if (a <= 0.) {
*tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
c__ * 2.); c__ * 2.);
} else { } else {
*tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)) *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))
)); ));
} }
if (*tau < lbd || *tau > ubd) { if (*tau < lbd || *tau > ubd) {
*tau = (lbd + ubd) / 2.; *tau = (lbd + ubd) / 2.;
} }
if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) {
*tau = 0.; *tau = 0.;
} else { } else {
temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau
* z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / ( * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / (
d__[3] * (d__[3] - *tau)); d__[3] * (d__[3] - *tau));
if (temp <= 0.) { if (temp <= 0.) {
lbd = *tau; lbd = *tau;
} else { } else {
ubd = *tau; ubd = *tau;
} }
if (abs(*finit) <= abs(temp)) { if (abs(*finit) <= abs(temp)) {
*tau = 0.; *tau = 0.;
} }
} }
} }
/* get machine parameters for possible scaling to avoid overflow */ /* get machine parameters for possible scaling to avoid overflow */
@ -291,75 +291,75 @@ f"> */
if (*orgati) { if (*orgati) {
/* Computing MIN */ /* Computing MIN */
d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - * d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - *
tau, abs(d__2)); tau, abs(d__2));
temp = min(d__3,d__4); temp = min(d__3,d__4);
} else { } else {
/* Computing MIN */ /* Computing MIN */
d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - * d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - *
tau, abs(d__2)); tau, abs(d__2));
temp = min(d__3,d__4); temp = min(d__3,d__4);
} }
scale = FALSE_; scale = FALSE_;
if (temp <= small1) { if (temp <= small1) {
scale = TRUE_; scale = TRUE_;
if (temp <= small2) { if (temp <= small2) {
/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */ /* Scale up by power of radix nearest 1/SAFMIN**(2/3) */
sclfac = sminv2; sclfac = sminv2;
sclinv = small2; sclinv = small2;
} else { } else {
/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */ /* Scale up by power of radix nearest 1/SAFMIN**(1/3) */
sclfac = sminv1; sclfac = sminv1;
sclinv = small1; sclinv = small1;
} }
/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */ /* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */
for (i__ = 1; i__ <= 3; ++i__) { for (i__ = 1; i__ <= 3; ++i__) {
dscale[i__ - 1] = d__[i__] * sclfac; dscale[i__ - 1] = d__[i__] * sclfac;
zscale[i__ - 1] = z__[i__] * sclfac; zscale[i__ - 1] = z__[i__] * sclfac;
/* L10: */ /* L10: */
} }
*tau *= sclfac; *tau *= sclfac;
lbd *= sclfac; lbd *= sclfac;
ubd *= sclfac; ubd *= sclfac;
} else { } else {
/* Copy D and Z to DSCALE and ZSCALE */ /* Copy D and Z to DSCALE and ZSCALE */
for (i__ = 1; i__ <= 3; ++i__) { for (i__ = 1; i__ <= 3; ++i__) {
dscale[i__ - 1] = d__[i__]; dscale[i__ - 1] = d__[i__];
zscale[i__ - 1] = z__[i__]; zscale[i__ - 1] = z__[i__];
/* L20: */ /* L20: */
} }
} }
fc = 0.; fc = 0.;
df = 0.; df = 0.;
ddf = 0.; ddf = 0.;
for (i__ = 1; i__ <= 3; ++i__) { for (i__ = 1; i__ <= 3; ++i__) {
temp = 1. / (dscale[i__ - 1] - *tau); temp = 1. / (dscale[i__ - 1] - *tau);
temp1 = zscale[i__ - 1] * temp; temp1 = zscale[i__ - 1] * temp;
temp2 = temp1 * temp; temp2 = temp1 * temp;
temp3 = temp2 * temp; temp3 = temp2 * temp;
fc += temp1 / dscale[i__ - 1]; fc += temp1 / dscale[i__ - 1];
df += temp2; df += temp2;
ddf += temp3; ddf += temp3;
/* L30: */ /* L30: */
} }
f = *finit + *tau * fc; f = *finit + *tau * fc;
if (abs(f) <= 0.) { if (abs(f) <= 0.) {
goto L60; goto L60;
} }
if (f <= 0.) { if (f <= 0.) {
lbd = *tau; lbd = *tau;
} else { } else {
ubd = *tau; ubd = *tau;
} }
/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */ /* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */
@ -377,71 +377,71 @@ f"> */
for (niter = iter; niter <= 40; ++niter) { for (niter = iter; niter <= 40; ++niter) {
if (*orgati) { if (*orgati) {
temp1 = dscale[1] - *tau; temp1 = dscale[1] - *tau;
temp2 = dscale[2] - *tau; temp2 = dscale[2] - *tau;
} else { } else {
temp1 = dscale[0] - *tau; temp1 = dscale[0] - *tau;
temp2 = dscale[1] - *tau; temp2 = dscale[1] - *tau;
} }
a = (temp1 + temp2) * f - temp1 * temp2 * df; a = (temp1 + temp2) * f - temp1 * temp2 * df;
b = temp1 * temp2 * f; b = temp1 * temp2 * f;
c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf; c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf;
/* Computing MAX */ /* Computing MAX */
d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__); d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__);
temp = max(d__1,d__2); temp = max(d__1,d__2);
a /= temp; a /= temp;
b /= temp; b /= temp;
c__ /= temp; c__ /= temp;
if (c__ == 0.) { if (c__ == 0.) {
eta = b / a; eta = b / a;
} else if (a <= 0.) { } else if (a <= 0.) {
eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__
* 2.); * 2.);
} else { } else {
eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))
); );
} }
if (f * eta >= 0.) { if (f * eta >= 0.) {
eta = -f / df; eta = -f / df;
} }
*tau += eta; *tau += eta;
if (*tau < lbd || *tau > ubd) { if (*tau < lbd || *tau > ubd) {
*tau = (lbd + ubd) / 2.; *tau = (lbd + ubd) / 2.;
} }
fc = 0.; fc = 0.;
erretm = 0.; erretm = 0.;
df = 0.; df = 0.;
ddf = 0.; ddf = 0.;
for (i__ = 1; i__ <= 3; ++i__) { for (i__ = 1; i__ <= 3; ++i__) {
if (dscale[i__ - 1] - *tau != 0.) { if (dscale[i__ - 1] - *tau != 0.) {
temp = 1. / (dscale[i__ - 1] - *tau); temp = 1. / (dscale[i__ - 1] - *tau);
temp1 = zscale[i__ - 1] * temp; temp1 = zscale[i__ - 1] * temp;
temp2 = temp1 * temp; temp2 = temp1 * temp;
temp3 = temp2 * temp; temp3 = temp2 * temp;
temp4 = temp1 / dscale[i__ - 1]; temp4 = temp1 / dscale[i__ - 1];
fc += temp4; fc += temp4;
erretm += abs(temp4); erretm += abs(temp4);
df += temp2; df += temp2;
ddf += temp3; ddf += temp3;
} else { } else {
goto L60; goto L60;
} }
/* L40: */ /* L40: */
} }
f = *finit + *tau * fc; f = *finit + *tau * fc;
erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df; erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df;
if (abs(f) <= eps * 4. * erretm || ubd - lbd <= eps * 4. * abs(*tau)) if (abs(f) <= eps * 4. * erretm || ubd - lbd <= eps * 4. * abs(*tau))
{ {
goto L60; goto L60;
} }
if (f <= 0.) { if (f <= 0.) {
lbd = *tau; lbd = *tau;
} else { } else {
ubd = *tau; ubd = *tau;
} }
/* L50: */ /* L50: */
} }
*info = 1; *info = 1;
@ -450,7 +450,7 @@ L60:
/* Undo scaling */ /* Undo scaling */
if (scale) { if (scale) {
*tau *= sclinv; *tau *= sclinv;
} }
return 0; return 0;
@ -459,5 +459,5 @@ L60:
} /* dlaed6_ */ } /* dlaed6_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

148
lib/linalg/dlaed7.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed7.f -- translated by f2c (version 20200916). /* fortran/dlaed7.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -282,12 +282,12 @@ f"> */
/* > at Berkeley, USA */ /* > at Berkeley, USA */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz, /* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz,
integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__,
doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer
*cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer * *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer *
perm, integer *givptr, integer *givcol, doublereal *givnum, perm, integer *givptr, integer *givcol, doublereal *givnum,
doublereal *work, integer *iwork, integer *info) doublereal *work, integer *iwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer q_dim1, q_offset, i__1, i__2; integer q_dim1, q_offset, i__1, i__2;
@ -297,25 +297,25 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr; integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
integer indxc, indxp; integer indxc, indxp;
extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *, extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *), dlaed9_(integer *, doublereal *, integer *, integer *, integer *), dlaed9_(integer *,
integer *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dlaeda_(integer *, integer *, integer *, integer *, integer *), dlaeda_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal integer *, integer *, integer *, integer *, integer *, doublereal
*, doublereal *, integer *, doublereal *, doublereal *, integer *) *, doublereal *, integer *, doublereal *, doublereal *, integer *)
; ;
integer idlmda; integer idlmda;
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *, integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen); ftnlen);
integer coltyp; integer coltyp;
@ -362,26 +362,26 @@ f"> */
*info = 0; *info = 0;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*icompq == 1 && *qsiz < *n) { } else if (*icompq == 1 && *qsiz < *n) {
*info = -3; *info = -3;
} else if (*ldq < max(1,*n)) { } else if (*ldq < max(1,*n)) {
*info = -9; *info = -9;
} else if (min(1,*n) > *cutpnt || *n < *cutpnt) { } else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
*info = -12; *info = -12;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAED7", &i__1, (ftnlen)6); xerbla_((char *)"DLAED7", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
/* The following values are for bookkeeping purposes only. They are */ /* The following values are for bookkeeping purposes only. They are */
@ -389,9 +389,9 @@ f"> */
/* used by a particular array in DLAED8 and DLAED9. */ /* used by a particular array in DLAED8 and DLAED9. */
if (*icompq == 1) { if (*icompq == 1) {
ldq2 = *qsiz; ldq2 = *qsiz;
} else { } else {
ldq2 = *n; ldq2 = *n;
} }
iz = 1; iz = 1;
@ -411,64 +411,64 @@ f"> */
ptr = pow_ii(&c__2, tlvls) + 1; ptr = pow_ii(&c__2, tlvls) + 1;
i__1 = *curlvl - 1; i__1 = *curlvl - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *tlvls - i__; i__2 = *tlvls - i__;
ptr += pow_ii(&c__2, &i__2); ptr += pow_ii(&c__2, &i__2);
/* L10: */ /* L10: */
} }
curr = ptr + *curpbm; curr = ptr + *curpbm;
dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], & dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz
+ *n], info); + *n], info);
/* When solving the final problem, we no longer need the stored data, */ /* When solving the final problem, we no longer need the stored data, */
/* so we will overwrite the data from this level onto the previously */ /* so we will overwrite the data from this level onto the previously */
/* used storage space. */ /* used storage space. */
if (*curlvl == *tlvls) { if (*curlvl == *tlvls) {
qptr[curr] = 1; qptr[curr] = 1;
prmptr[curr] = 1; prmptr[curr] = 1;
givptr[curr] = 1; givptr[curr] = 1;
} }
/* Sort and Deflate eigenvalues. */ /* Sort and Deflate eigenvalues. */
dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho,
cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], & cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], &
perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1) perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1)
+ 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[ + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[
indx], info); indx], info);
prmptr[curr + 1] = prmptr[curr] + *n; prmptr[curr + 1] = prmptr[curr] + *n;
givptr[curr + 1] += givptr[curr]; givptr[curr + 1] += givptr[curr];
/* Solve Secular Equation. */ /* Solve Secular Equation. */
if (k != 0) { if (k != 0) {
dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda],
&work[iw], &qstore[qptr[curr]], &k, info); &work[iw], &qstore[qptr[curr]], &k, info);
if (*info != 0) { if (*info != 0) {
goto L30; goto L30;
} }
if (*icompq == 1) { if (*icompq == 1) {
dgemm_((char *)"N", (char *)"N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[ dgemm_((char *)"N", (char *)"N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[
qptr[curr]], &k, &c_b11, &q[q_offset], ldq, (ftnlen)1, ( qptr[curr]], &k, &c_b11, &q[q_offset], ldq, (ftnlen)1, (
ftnlen)1); ftnlen)1);
} }
/* Computing 2nd power */ /* Computing 2nd power */
i__1 = k; i__1 = k;
qptr[curr + 1] = qptr[curr] + i__1 * i__1; qptr[curr + 1] = qptr[curr] + i__1 * i__1;
/* Prepare the INDXQ sorting permutation. */ /* Prepare the INDXQ sorting permutation. */
n1 = k; n1 = k;
n2 = *n - k; n2 = *n - k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
} else { } else {
qptr[curr + 1] = qptr[curr]; qptr[curr + 1] = qptr[curr];
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
indxq[i__] = i__; indxq[i__] = i__;
/* L20: */ /* L20: */
} }
} }
L30: L30:
@ -479,5 +479,5 @@ L30:
} /* dlaed7_ */ } /* dlaed7_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

276
lib/linalg/dlaed8.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed8.f -- translated by f2c (version 20200916). /* fortran/dlaed8.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -263,12 +263,12 @@ f"> */
/* > at Berkeley, USA */ /* > at Berkeley, USA */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer /* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer
*qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, *qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq,
doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda, doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda,
doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer
*givptr, integer *givcol, doublereal *givnum, integer *indxp, integer *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer
*indx, integer *info) *indx, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
@ -284,17 +284,17 @@ f"> */
integer k2, n1, n2, jp, n1p1; integer k2, n1, n2, jp, n1p1;
doublereal eps, tau, tol; doublereal eps, tau, tol;
integer jlam, imax, jmax; integer jlam, imax, jmax;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dscal_( doublereal *, integer *, doublereal *, doublereal *), dscal_(
integer *, doublereal *, doublereal *, integer *), dcopy_(integer integer *, doublereal *, doublereal *, integer *), dcopy_(integer
*, doublereal *, integer *, doublereal *, integer *); *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen); ftnlen);
extern integer idamax_(integer *, doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *, integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -345,22 +345,22 @@ f"> */
*info = 0; *info = 0;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -3; *info = -3;
} else if (*icompq == 1 && *qsiz < *n) { } else if (*icompq == 1 && *qsiz < *n) {
*info = -4; *info = -4;
} else if (*ldq < max(1,*n)) { } else if (*ldq < max(1,*n)) {
*info = -7; *info = -7;
} else if (*cutpnt < min(1,*n) || *cutpnt > *n) { } else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
*info = -10; *info = -10;
} else if (*ldq2 < max(1,*n)) { } else if (*ldq2 < max(1,*n)) {
*info = -14; *info = -14;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAED8", &i__1, (ftnlen)6); xerbla_((char *)"DLAED8", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Need to initialize GIVPTR to O here in case of quick exit */ /* Need to initialize GIVPTR to O here in case of quick exit */
@ -373,7 +373,7 @@ f"> */
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
n1 = *cutpnt; n1 = *cutpnt;
@ -381,7 +381,7 @@ f"> */
n1p1 = n1 + 1; n1p1 = n1 + 1;
if (*rho < 0.) { if (*rho < 0.) {
dscal_(&n2, &c_b3, &z__[n1p1], &c__1); dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
} }
/* Normalize z so that norm(z) = 1 */ /* Normalize z so that norm(z) = 1 */
@ -389,7 +389,7 @@ f"> */
t = 1. / sqrt(2.); t = 1. / sqrt(2.);
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
indx[j] = j; indx[j] = j;
/* L10: */ /* L10: */
} }
dscal_(n, &t, &z__[1], &c__1); dscal_(n, &t, &z__[1], &c__1);
@ -399,13 +399,13 @@ f"> */
i__1 = *n; i__1 = *n;
for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
indxq[i__] += *cutpnt; indxq[i__] += *cutpnt;
/* L20: */ /* L20: */
} }
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]]; dlamda[i__] = d__[indxq[i__]];
w[i__] = z__[indxq[i__]]; w[i__] = z__[indxq[i__]];
/* L30: */ /* L30: */
} }
i__ = 1; i__ = 1;
@ -413,8 +413,8 @@ f"> */
dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = dlamda[indx[i__]]; d__[i__] = dlamda[indx[i__]];
z__[i__] = w[indx[i__]]; z__[i__] = w[indx[i__]];
/* L40: */ /* L40: */
} }
@ -430,25 +430,25 @@ f"> */
/* elements in D. */ /* elements in D. */
if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
*k = 0; *k = 0;
if (*icompq == 0) { if (*icompq == 0) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]]; perm[j] = indxq[indx[j]];
/* L50: */ /* L50: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]]; perm[j] = indxq[indx[j]];
dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1
+ 1], &c__1); + 1], &c__1);
/* L60: */ /* L60: */
} }
dlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, dlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq,
(ftnlen)1); (ftnlen)1);
} }
return 0; return 0;
} }
/* If there are multiple eigenvalues then the problem deflates. Here */ /* If there are multiple eigenvalues then the problem deflates. Here */
@ -461,90 +461,90 @@ f"> */
k2 = *n + 1; k2 = *n + 1;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */ /* Deflate due to small z component. */
--k2; --k2;
indxp[k2] = j; indxp[k2] = j;
if (j == *n) { if (j == *n) {
goto L110; goto L110;
} }
} else { } else {
jlam = j; jlam = j;
goto L80; goto L80;
} }
/* L70: */ /* L70: */
} }
L80: L80:
++j; ++j;
if (j > *n) { if (j > *n) {
goto L100; goto L100;
} }
if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */ /* Deflate due to small z component. */
--k2; --k2;
indxp[k2] = j; indxp[k2] = j;
} else { } else {
/* Check if eigenvalues are close enough to allow deflation. */ /* Check if eigenvalues are close enough to allow deflation. */
s = z__[jlam]; s = z__[jlam];
c__ = z__[j]; c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */ /* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */ /* destructive underflow. */
tau = dlapy2_(&c__, &s); tau = dlapy2_(&c__, &s);
t = d__[j] - d__[jlam]; t = d__[j] - d__[jlam];
c__ /= tau; c__ /= tau;
s = -s / tau; s = -s / tau;
if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
/* Deflation is possible. */ /* Deflation is possible. */
z__[j] = tau; z__[j] = tau;
z__[jlam] = 0.; z__[jlam] = 0.;
/* Record the appropriate Givens rotation */ /* Record the appropriate Givens rotation */
++(*givptr); ++(*givptr);
givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
givcol[(*givptr << 1) + 2] = indxq[indx[j]]; givcol[(*givptr << 1) + 2] = indxq[indx[j]];
givnum[(*givptr << 1) + 1] = c__; givnum[(*givptr << 1) + 1] = c__;
givnum[(*givptr << 1) + 2] = s; givnum[(*givptr << 1) + 2] = s;
if (*icompq == 1) { if (*icompq == 1) {
drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[
indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s); indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
} }
t = d__[jlam] * c__ * c__ + d__[j] * s * s; t = d__[jlam] * c__ * c__ + d__[j] * s * s;
d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
d__[jlam] = t; d__[jlam] = t;
--k2; --k2;
i__ = 1; i__ = 1;
L90: L90:
if (k2 + i__ <= *n) { if (k2 + i__ <= *n) {
if (d__[jlam] < d__[indxp[k2 + i__]]) { if (d__[jlam] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__]; indxp[k2 + i__ - 1] = indxp[k2 + i__];
indxp[k2 + i__] = jlam; indxp[k2 + i__] = jlam;
++i__; ++i__;
goto L90; goto L90;
} else { } else {
indxp[k2 + i__ - 1] = jlam; indxp[k2 + i__ - 1] = jlam;
} }
} else { } else {
indxp[k2 + i__ - 1] = jlam; indxp[k2 + i__ - 1] = jlam;
} }
jlam = j; jlam = j;
} else { } else {
++(*k); ++(*k);
w[*k] = z__[jlam]; w[*k] = z__[jlam];
dlamda[*k] = d__[jlam]; dlamda[*k] = d__[jlam];
indxp[*k] = jlam; indxp[*k] = jlam;
jlam = j; jlam = j;
} }
} }
goto L80; goto L80;
L100: L100:
@ -564,39 +564,39 @@ L110:
/* while those which were deflated go into the last N - K slots. */ /* while those which were deflated go into the last N - K slots. */
if (*icompq == 0) { if (*icompq == 0) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
jp = indxp[j]; jp = indxp[j];
dlamda[j] = d__[jp]; dlamda[j] = d__[jp];
perm[j] = indxq[indx[jp]]; perm[j] = indxq[indx[jp]];
/* L120: */ /* L120: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
jp = indxp[j]; jp = indxp[j];
dlamda[j] = d__[jp]; dlamda[j] = d__[jp];
perm[j] = indxq[indx[jp]]; perm[j] = indxq[indx[jp]];
dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
, &c__1); , &c__1);
/* L130: */ /* L130: */
} }
} }
/* The deflated eigenvalues and their corresponding vectors go back */ /* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */ /* into the last N - K slots of D and Q respectively. */
if (*k < *n) { if (*k < *n) {
if (*icompq == 0) { if (*icompq == 0) {
i__1 = *n - *k; i__1 = *n - *k;
dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
} else { } else {
i__1 = *n - *k; i__1 = *n - *k;
dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = *n - *k; i__1 = *n - *k;
dlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* dlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*
k + 1) * q_dim1 + 1], ldq, (ftnlen)1); k + 1) * q_dim1 + 1], ldq, (ftnlen)1);
} }
} }
return 0; return 0;
@ -606,5 +606,5 @@ L110:
} /* dlaed8_ */ } /* dlaed8_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

118
lib/linalg/dlaed9.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaed9.f -- translated by f2c (version 20200916). /* fortran/dlaed9.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -176,10 +176,10 @@ f"> */
/* > at Berkeley, USA */ /* > at Berkeley, USA */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, /* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop,
integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal * integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal *
rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds,
integer *info) integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2;
@ -192,10 +192,10 @@ f"> */
integer i__, j; integer i__, j;
doublereal temp; doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *); extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlaed4_(integer *, integer *, doublereal *, integer *), dlaed4_(integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *); doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *); extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
@ -238,28 +238,28 @@ f"> */
*info = 0; *info = 0;
if (*k < 0) { if (*k < 0) {
*info = -1; *info = -1;
} else if (*kstart < 1 || *kstart > max(1,*k)) { } else if (*kstart < 1 || *kstart > max(1,*k)) {
*info = -2; *info = -2;
} else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) { } else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) {
*info = -3; *info = -3;
} else if (*n < *k) { } else if (*n < *k) {
*info = -4; *info = -4;
} else if (*ldq < max(1,*k)) { } else if (*ldq < max(1,*k)) {
*info = -7; *info = -7;
} else if (*lds < max(1,*k)) { } else if (*lds < max(1,*k)) {
*info = -12; *info = -12;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAED9", &i__1, (ftnlen)6); xerbla_((char *)"DLAED9", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*k == 0) { if (*k == 0) {
return 0; return 0;
} }
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
@ -281,34 +281,34 @@ f"> */
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */ /* L10: */
} }
i__1 = *kstop; i__1 = *kstop;
for (j = *kstart; j <= i__1; ++j) { for (j = *kstart; j <= i__1; ++j) {
dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
info); info);
/* If the zero finder fails, the computation is terminated. */ /* If the zero finder fails, the computation is terminated. */
if (*info != 0) { if (*info != 0) {
goto L120; goto L120;
} }
/* L20: */ /* L20: */
} }
if (*k == 1 || *k == 2) { if (*k == 1 || *k == 2) {
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *k; i__2 = *k;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
s[j + i__ * s_dim1] = q[j + i__ * q_dim1]; s[j + i__ * s_dim1] = q[j + i__ * q_dim1];
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
goto L120; goto L120;
} }
/* Compute updated W. */ /* Compute updated W. */
@ -321,22 +321,22 @@ f"> */
dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L50: */ /* L50: */
} }
i__2 = *k; i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L60: */ /* L60: */
} }
/* L70: */ /* L70: */
} }
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = sqrt(-w[i__]); d__1 = sqrt(-w[i__]);
w[i__] = d_sign(&d__1, &s[i__ + s_dim1]); w[i__] = d_sign(&d__1, &s[i__ + s_dim1]);
/* L80: */ /* L80: */
} }
@ -344,17 +344,17 @@ f"> */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *k; i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1]; q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1];
/* L90: */ /* L90: */
} }
temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1); temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1);
i__2 = *k; i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp; s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp;
/* L100: */ /* L100: */
} }
/* L110: */ /* L110: */
} }
@ -366,5 +366,5 @@ L120:
} /* dlaed9_ */ } /* dlaed9_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

158
lib/linalg/dlaeda.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaeda.f -- translated by f2c (version 20200916). /* fortran/dlaeda.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -189,10 +189,10 @@ f"> */
/* > at Berkeley, USA */ /* > at Berkeley, USA */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, /* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl,
integer *curpbm, integer *prmptr, integer *perm, integer *givptr, integer *curpbm, integer *prmptr, integer *perm, integer *givptr,
integer *givcol, doublereal *givnum, doublereal *q, integer *qptr, integer *givcol, doublereal *givnum, doublereal *q, integer *qptr,
doublereal *z__, doublereal *ztemp, integer *info) doublereal *z__, doublereal *ztemp, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer i__1, i__2, i__3; integer i__1, i__2, i__3;
@ -203,14 +203,14 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, k, mid, ptr; integer i__, k, mid, ptr;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *); doublereal *, integer *, doublereal *, doublereal *);
integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1; integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *, extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *, doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), xerbla_(char *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *,
integer *, ftnlen); integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -251,18 +251,18 @@ f"> */
*info = 0; *info = 0;
if (*n < 0) { if (*n < 0) {
*info = -1; *info = -1;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLAEDA", &i__1, (ftnlen)6); xerbla_((char *)"DLAEDA", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
/* Determine location of first number in second half. */ /* Determine location of first number in second half. */
@ -284,19 +284,19 @@ f"> */
/* roots. */ /* roots. */
bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + .5); bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + .5);
bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) + bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) +
.5); .5);
i__1 = mid - bsiz1 - 1; i__1 = mid - bsiz1 - 1;
for (k = 1; k <= i__1; ++k) { for (k = 1; k <= i__1; ++k) {
z__[k] = 0.; z__[k] = 0.;
/* L10: */ /* L10: */
} }
dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], & dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &
c__1); c__1);
dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1);
i__1 = *n; i__1 = *n;
for (k = mid + bsiz2; k <= i__1; ++k) { for (k = mid + bsiz2; k <= i__1; ++k) {
z__[k] = 0.; z__[k] = 0.;
/* L20: */ /* L20: */
} }
@ -307,43 +307,43 @@ f"> */
ptr = pow_ii(&c__2, tlvls) + 1; ptr = pow_ii(&c__2, tlvls) + 1;
i__1 = *curlvl - 1; i__1 = *curlvl - 1;
for (k = 1; k <= i__1; ++k) { for (k = 1; k <= i__1; ++k) {
i__2 = *curlvl - k; i__2 = *curlvl - k;
i__3 = *curlvl - k - 1; i__3 = *curlvl - k - 1;
curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) - curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) -
1; 1;
psiz1 = prmptr[curr + 1] - prmptr[curr]; psiz1 = prmptr[curr + 1] - prmptr[curr];
psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
zptr1 = mid - psiz1; zptr1 = mid - psiz1;
/* Apply Givens at CURR and CURR+1 */ /* Apply Givens at CURR and CURR+1 */
i__2 = givptr[curr + 1] - 1; i__2 = givptr[curr + 1] - 1;
for (i__ = givptr[curr]; i__ <= i__2; ++i__) { for (i__ = givptr[curr]; i__ <= i__2; ++i__) {
drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, & drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, &
z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[( z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[(
i__ << 1) + 1], &givnum[(i__ << 1) + 2]); i__ << 1) + 1], &givnum[(i__ << 1) + 2]);
/* L30: */ /* L30: */
} }
i__2 = givptr[curr + 2] - 1; i__2 = givptr[curr + 2] - 1;
for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) { for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) {
drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[ drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[
mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ <<
1) + 1], &givnum[(i__ << 1) + 2]); 1) + 1], &givnum[(i__ << 1) + 2]);
/* L40: */ /* L40: */
} }
psiz1 = prmptr[curr + 1] - prmptr[curr]; psiz1 = prmptr[curr + 1] - prmptr[curr];
psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
i__2 = psiz1 - 1; i__2 = psiz1 - 1;
for (i__ = 0; i__ <= i__2; ++i__) { for (i__ = 0; i__ <= i__2; ++i__) {
ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1]; ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1];
/* L50: */ /* L50: */
} }
i__2 = psiz2 - 1; i__2 = psiz2 - 1;
for (i__ = 0; i__ <= i__2; ++i__) { for (i__ = 0; i__ <= i__2; ++i__) {
ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] -
1]; 1];
/* L60: */ /* L60: */
} }
/* Multiply Blocks at CURR and CURR+1 */ /* Multiply Blocks at CURR and CURR+1 */
@ -351,27 +351,27 @@ f"> */
/* the SQRT in case the machine underestimates one of these */ /* the SQRT in case the machine underestimates one of these */
/* square roots. */ /* square roots. */
bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) +
.5); .5);
bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1]) bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])
) + .5); ) + .5);
if (bsiz1 > 0) { if (bsiz1 > 0) {
dgemv_((char *)"T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & dgemv_((char *)"T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &
ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1, (ftnlen)1); ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1, (ftnlen)1);
} }
i__2 = psiz1 - bsiz1; i__2 = psiz1 - bsiz1;
dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1);
if (bsiz2 > 0) { if (bsiz2 > 0) {
dgemv_((char *)"T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, & dgemv_((char *)"T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &
ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1, ( ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1, (
ftnlen)1); ftnlen)1);
} }
i__2 = psiz2 - bsiz2; i__2 = psiz2 - bsiz2;
dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], & dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &
c__1); c__1);
i__2 = *tlvls - k; i__2 = *tlvls - k;
ptr += pow_ii(&c__2, &i__2); ptr += pow_ii(&c__2, &i__2);
/* L70: */ /* L70: */
} }
@ -382,5 +382,5 @@ f"> */
} /* dlaeda_ */ } /* dlaeda_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

92
lib/linalg/dlaev2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaev2.f -- translated by f2c (version 20200916). /* fortran/dlaev2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -136,8 +136,8 @@ f"> */
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, /* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1) doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1)
{ {
/* System generated locals */ /* System generated locals */
doublereal d__1; doublereal d__1;
@ -176,81 +176,81 @@ f"> */
tb = *b + *b; tb = *b + *b;
ab = abs(tb); ab = abs(tb);
if (abs(*a) > abs(*c__)) { if (abs(*a) > abs(*c__)) {
acmx = *a; acmx = *a;
acmn = *c__; acmn = *c__;
} else { } else {
acmx = *c__; acmx = *c__;
acmn = *a; acmn = *a;
} }
if (adf > ab) { if (adf > ab) {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = ab / adf; d__1 = ab / adf;
rt = adf * sqrt(d__1 * d__1 + 1.); rt = adf * sqrt(d__1 * d__1 + 1.);
} else if (adf < ab) { } else if (adf < ab) {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = adf / ab; d__1 = adf / ab;
rt = ab * sqrt(d__1 * d__1 + 1.); rt = ab * sqrt(d__1 * d__1 + 1.);
} else { } else {
/* Includes case AB=ADF=0 */ /* Includes case AB=ADF=0 */
rt = ab * sqrt(2.); rt = ab * sqrt(2.);
} }
if (sm < 0.) { if (sm < 0.) {
*rt1 = (sm - rt) * .5; *rt1 = (sm - rt) * .5;
sgn1 = -1; sgn1 = -1;
/* Order of execution important. */ /* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */ /* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */ /* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else if (sm > 0.) { } else if (sm > 0.) {
*rt1 = (sm + rt) * .5; *rt1 = (sm + rt) * .5;
sgn1 = 1; sgn1 = 1;
/* Order of execution important. */ /* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */ /* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */ /* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else { } else {
/* Includes case RT1 = RT2 = 0 */ /* Includes case RT1 = RT2 = 0 */
*rt1 = rt * .5; *rt1 = rt * .5;
*rt2 = rt * -.5; *rt2 = rt * -.5;
sgn1 = 1; sgn1 = 1;
} }
/* Compute the eigenvector */ /* Compute the eigenvector */
if (df >= 0.) { if (df >= 0.) {
cs = df + rt; cs = df + rt;
sgn2 = 1; sgn2 = 1;
} else { } else {
cs = df - rt; cs = df - rt;
sgn2 = -1; sgn2 = -1;
} }
acs = abs(cs); acs = abs(cs);
if (acs > ab) { if (acs > ab) {
ct = -tb / cs; ct = -tb / cs;
*sn1 = 1. / sqrt(ct * ct + 1.); *sn1 = 1. / sqrt(ct * ct + 1.);
*cs1 = ct * *sn1; *cs1 = ct * *sn1;
} else { } else {
if (ab == 0.) { if (ab == 0.) {
*cs1 = 1.; *cs1 = 1.;
*sn1 = 0.; *sn1 = 0.;
} else { } else {
tn = -cs / tb; tn = -cs / tb;
*cs1 = 1. / sqrt(tn * tn + 1.); *cs1 = 1. / sqrt(tn * tn + 1.);
*sn1 = tn * *cs1; *sn1 = tn * *cs1;
} }
} }
if (sgn1 == sgn2) { if (sgn1 == sgn2) {
tn = *cs1; tn = *cs1;
*cs1 = -(*sn1); *cs1 = -(*sn1);
*sn1 = tn; *sn1 = tn;
} }
return 0; return 0;
@ -259,5 +259,5 @@ f"> */
} /* dlaev2_ */ } /* dlaev2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

354
lib/linalg/dlals0.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlals0.f -- translated by f2c (version 20200916). /* fortran/dlals0.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -291,17 +291,17 @@ f"> */
/* > Osni Marques, LBNL/NERSC, USA \n */ /* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr, /* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal
*bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol,
integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal * integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *
poles, doublereal *difl, doublereal *difr, doublereal *z__, integer * poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *
k, doublereal *c__, doublereal *s, doublereal *work, integer *info) k, doublereal *c__, doublereal *s, doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset,
difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1,
poles_offset, i__1, i__2; poles_offset, i__1, i__2;
doublereal d__1; doublereal d__1;
/* Local variables */ /* Local variables */
@ -309,22 +309,22 @@ f"> */
doublereal dj; doublereal dj;
integer nlp1; integer nlp1;
doublereal temp; doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *); doublereal *, integer *, doublereal *, doublereal *);
extern doublereal dnrm2_(integer *, doublereal *, integer *); extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *); integer *);
doublereal diflj, difrj, dsigj; doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *, extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *, doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *); doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *); extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *, extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlacpy_(char *, integer *, integer integer *, integer *, ftnlen), dlacpy_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, ftnlen), *, doublereal *, integer *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen); xerbla_(char *, integer *, ftnlen);
doublereal dsigjp; doublereal dsigjp;
@ -382,32 +382,32 @@ f"> */
n = *nl + *nr + 1; n = *nl + *nr + 1;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*nl < 1) { } else if (*nl < 1) {
*info = -2; *info = -2;
} else if (*nr < 1) { } else if (*nr < 1) {
*info = -3; *info = -3;
} else if (*sqre < 0 || *sqre > 1) { } else if (*sqre < 0 || *sqre > 1) {
*info = -4; *info = -4;
} else if (*nrhs < 1) { } else if (*nrhs < 1) {
*info = -5; *info = -5;
} else if (*ldb < n) { } else if (*ldb < n) {
*info = -7; *info = -7;
} else if (*ldbx < n) { } else if (*ldbx < n) {
*info = -9; *info = -9;
} else if (*givptr < 0) { } else if (*givptr < 0) {
*info = -11; *info = -11;
} else if (*ldgcol < n) { } else if (*ldgcol < n) {
*info = -13; *info = -13;
} else if (*ldgnum < n) { } else if (*ldgnum < n) {
*info = -15; *info = -15;
} else if (*k < 1) { } else if (*k < 1) {
*info = -20; *info = -20;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLALS0", &i__1, (ftnlen)6); xerbla_((char *)"DLALS0", &i__1, (ftnlen)6);
return 0; return 0;
} }
m = n + *sqre; m = n + *sqre;
@ -419,91 +419,91 @@ f"> */
/* Step (1L): apply back the Givens rotations performed. */ /* Step (1L): apply back the Givens rotations performed. */
i__1 = *givptr; i__1 = *givptr;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
(givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]); (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
/* L10: */ /* L10: */
} }
/* Step (2L): permute rows of B. */ /* Step (2L): permute rows of B. */
dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
i__1 = n; i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1],
ldbx); ldbx);
/* L20: */ /* L20: */
} }
/* Step (3L): apply the inverse of the left singular vector */ /* Step (3L): apply the inverse of the left singular vector */
/* matrix to BX. */ /* matrix to BX. */
if (*k == 1) { if (*k == 1) {
dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
if (z__[1] < 0.) { if (z__[1] < 0.) {
dscal_(nrhs, &c_b5, &b[b_offset], ldb); dscal_(nrhs, &c_b5, &b[b_offset], ldb);
} }
} else { } else {
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
diflj = difl[j]; diflj = difl[j];
dj = poles[j + poles_dim1]; dj = poles[j + poles_dim1];
dsigj = -poles[j + (poles_dim1 << 1)]; dsigj = -poles[j + (poles_dim1 << 1)];
if (j < *k) { if (j < *k) {
difrj = -difr[j + difr_dim1]; difrj = -difr[j + difr_dim1];
dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; dsigjp = -poles[j + 1 + (poles_dim1 << 1)];
} }
if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) { if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) {
work[j] = 0.; work[j] = 0.;
} else { } else {
work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj / work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj /
(poles[j + (poles_dim1 << 1)] + dj); (poles[j + (poles_dim1 << 1)] + dj);
} }
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
0.) { 0.) {
work[i__] = 0.; work[i__] = 0.;
} else { } else {
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
/ (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
dsigj) - diflj) / (poles[i__ + (poles_dim1 << dsigj) - diflj) / (poles[i__ + (poles_dim1 <<
1)] + dj); 1)] + dj);
} }
/* L30: */ /* L30: */
} }
i__2 = *k; i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
0.) { 0.) {
work[i__] = 0.; work[i__] = 0.;
} else { } else {
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
/ (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
dsigjp) + difrj) / (poles[i__ + (poles_dim1 << dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
1)] + dj); 1)] + dj);
} }
/* L40: */ /* L40: */
} }
work[1] = -1.; work[1] = -1.;
temp = dnrm2_(k, &work[1], &c__1); temp = dnrm2_(k, &work[1], &c__1);
dgemv_((char *)"T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & dgemv_((char *)"T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &
c__1, &c_b13, &b[j + b_dim1], ldb, (ftnlen)1); c__1, &c_b13, &b[j + b_dim1], ldb, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + dlascl_((char *)"G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j +
b_dim1], ldb, info, (ftnlen)1); b_dim1], ldb, info, (ftnlen)1);
/* L50: */ /* L50: */
} }
} }
/* Move the deflated rows of BX to B also. */ /* Move the deflated rows of BX to B also. */
if (*k < max(m,n)) { if (*k < max(m,n)) {
i__1 = n - *k; i__1 = n - *k;
dlacpy_((char *)"A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 dlacpy_((char *)"A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1
+ b_dim1], ldb, (ftnlen)1); + b_dim1], ldb, (ftnlen)1);
} }
} else { } else {
/* Apply back the right orthogonal transformations. */ /* Apply back the right orthogonal transformations. */
@ -511,84 +511,84 @@ f"> */
/* Step (1R): apply back the new right singular vector matrix */ /* Step (1R): apply back the new right singular vector matrix */
/* to B. */ /* to B. */
if (*k == 1) { if (*k == 1) {
dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
} else { } else {
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dsigj = poles[j + (poles_dim1 << 1)]; dsigj = poles[j + (poles_dim1 << 1)];
if (z__[j] == 0.) { if (z__[j] == 0.) {
work[j] = 0.; work[j] = 0.;
} else { } else {
work[j] = -z__[j] / difl[j] / (dsigj + poles[j + work[j] = -z__[j] / difl[j] / (dsigj + poles[j +
poles_dim1]) / difr[j + (difr_dim1 << 1)]; poles_dim1]) / difr[j + (difr_dim1 << 1)];
} }
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.) { if (z__[j] == 0.) {
work[i__] = 0.; work[i__] = 0.;
} else { } else {
d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; d__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[ work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[
i__ + difr_dim1]) / (dsigj + poles[i__ + i__ + difr_dim1]) / (dsigj + poles[i__ +
poles_dim1]) / difr[i__ + (difr_dim1 << 1)]; poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
} }
/* L60: */ /* L60: */
} }
i__2 = *k; i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.) { if (z__[j] == 0.) {
work[i__] = 0.; work[i__] = 0.;
} else { } else {
d__1 = -poles[i__ + (poles_dim1 << 1)]; d__1 = -poles[i__ + (poles_dim1 << 1)];
work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[ work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[
i__]) / (dsigj + poles[i__ + poles_dim1]) / i__]) / (dsigj + poles[i__ + poles_dim1]) /
difr[i__ + (difr_dim1 << 1)]; difr[i__ + (difr_dim1 << 1)];
} }
/* L70: */ /* L70: */
} }
dgemv_((char *)"T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], & dgemv_((char *)"T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
c__1, &c_b13, &bx[j + bx_dim1], ldbx, (ftnlen)1); c__1, &c_b13, &bx[j + bx_dim1], ldbx, (ftnlen)1);
/* L80: */ /* L80: */
} }
} }
/* Step (2R): if SQRE = 1, apply back the rotation that is */ /* Step (2R): if SQRE = 1, apply back the rotation that is */
/* related to the right null space of the subproblem. */ /* related to the right null space of the subproblem. */
if (*sqre == 1) { if (*sqre == 1) {
dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx);
drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__,
s); s);
} }
if (*k < max(m,n)) { if (*k < max(m,n)) {
i__1 = n - *k; i__1 = n - *k;
dlacpy_((char *)"A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + dlacpy_((char *)"A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 +
bx_dim1], ldbx, (ftnlen)1); bx_dim1], ldbx, (ftnlen)1);
} }
/* Step (3R): permute rows of B. */ /* Step (3R): permute rows of B. */
dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
if (*sqre == 1) { if (*sqre == 1) {
dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
} }
i__1 = n; i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1],
ldb); ldb);
/* L90: */ /* L90: */
} }
/* Step (4R): apply back the Givens rotations performed. */ /* Step (4R): apply back the Givens rotations performed. */
for (i__ = *givptr; i__ >= 1; --i__) { for (i__ = *givptr; i__ >= 1; --i__) {
d__1 = -givnum[i__ + givnum_dim1]; d__1 = -givnum[i__ + givnum_dim1];
drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
(givnum_dim1 << 1)], &d__1); (givnum_dim1 << 1)], &d__1);
/* L100: */ /* L100: */
} }
} }
return 0; return 0;
@ -598,5 +598,5 @@ f"> */
} /* dlals0_ */ } /* dlals0_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

274
lib/linalg/dlalsa.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlalsa.f -- translated by f2c (version 20200916). /* fortran/dlalsa.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -286,40 +286,40 @@ f"> */
/* > Osni Marques, LBNL/NERSC, USA \n */ /* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n, /* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n,
integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer * integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *
ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k,
doublereal *difl, doublereal *difr, doublereal *z__, doublereal * doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
poles, integer *givptr, integer *givcol, integer *ldgcol, integer * poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal * perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
work, integer *iwork, integer *info) work, integer *iwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1,
b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1, b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1,
difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset,
u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1,
i__2; i__2;
/* Builtin functions */ /* Builtin functions */
integer pow_ii(integer *, integer *); integer pow_ii(integer *, integer *);
/* Local variables */ /* Local variables */
integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1,
nlp1, lvl2, nrp1, nlvl, sqre; nlp1, lvl2, nrp1, nlvl, sqre;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
integer inode, ndiml, ndimr; integer inode, ndiml, ndimr;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlals0_(integer *, integer *, integer *, doublereal *, integer *), dlals0_(integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *, doublereal integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, doublereal *, *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dlasdt_(integer *, integer *, integer *, integer *, integer *), dlasdt_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *), xerbla_(char *, integer *, integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen); ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -388,26 +388,26 @@ f"> */
*info = 0; *info = 0;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*smlsiz < 3) { } else if (*smlsiz < 3) {
*info = -2; *info = -2;
} else if (*n < *smlsiz) { } else if (*n < *smlsiz) {
*info = -3; *info = -3;
} else if (*nrhs < 1) { } else if (*nrhs < 1) {
*info = -4; *info = -4;
} else if (*ldb < *n) { } else if (*ldb < *n) {
*info = -6; *info = -6;
} else if (*ldbx < *n) { } else if (*ldbx < *n) {
*info = -8; *info = -8;
} else if (*ldu < *n) { } else if (*ldu < *n) {
*info = -10; *info = -10;
} else if (*ldgcol < *n) { } else if (*ldgcol < *n) {
*info = -19; *info = -19;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLALSA", &i__1, (ftnlen)6); xerbla_((char *)"DLALSA", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Book-keeping and setting up the computation tree. */ /* Book-keeping and setting up the computation tree. */
@ -416,14 +416,14 @@ f"> */
ndiml = inode + *n; ndiml = inode + *n;
ndimr = ndiml + *n; ndimr = ndiml + *n;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz); smlsiz);
/* The following code applies back the left singular vector factors. */ /* The following code applies back the left singular vector factors. */
/* For applying back the right singular vector factors, go to 50. */ /* For applying back the right singular vector factors, go to 50. */
if (*icompq == 1) { if (*icompq == 1) {
goto L50; goto L50;
} }
/* The nodes on the bottom level of the tree were solved */ /* The nodes on the bottom level of the tree were solved */
@ -441,18 +441,18 @@ f"> */
/* NLF: starting row of the left subproblem */ /* NLF: starting row of the left subproblem */
/* NRF: starting row of the right subproblem */ /* NRF: starting row of the right subproblem */
i1 = i__ - 1; i1 = i__ - 1;
ic = iwork[inode + i1]; ic = iwork[inode + i1];
nl = iwork[ndiml + i1]; nl = iwork[ndiml + i1];
nr = iwork[ndimr + i1]; nr = iwork[ndimr + i1];
nlf = ic - nl; nlf = ic - nl;
nrf = ic + 1; nrf = ic + 1;
dgemm_((char *)"T", (char *)"N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf dgemm_((char *)"T", (char *)"N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf
+ b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, (ftnlen)1, ( + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, (ftnlen)1, (
ftnlen)1); ftnlen)1);
dgemm_((char *)"T", (char *)"N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf dgemm_((char *)"T", (char *)"N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf
+ b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, (ftnlen)1, ( + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, (ftnlen)1, (
ftnlen)1); ftnlen)1);
/* L10: */ /* L10: */
} }
@ -461,8 +461,8 @@ f"> */
i__1 = nd; i__1 = nd;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
ic = iwork[inode + i__ - 1]; ic = iwork[inode + i__ - 1];
dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx);
/* L20: */ /* L20: */
} }
@ -473,37 +473,37 @@ f"> */
sqre = 0; sqre = 0;
for (lvl = nlvl; lvl >= 1; --lvl) { for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1; lvl2 = (lvl << 1) - 1;
/* find the first node LF and last node LL on */ /* find the first node LF and last node LL on */
/* the current level LVL */ /* the current level LVL */
if (lvl == 1) { if (lvl == 1) {
lf = 1; lf = 1;
ll = 1; ll = 1;
} else { } else {
i__1 = lvl - 1; i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1); lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1; ll = (lf << 1) - 1;
} }
i__1 = ll; i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) { for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1; im1 = i__ - 1;
ic = iwork[inode + im1]; ic = iwork[inode + im1];
nl = iwork[ndiml + im1]; nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1]; nr = iwork[ndimr + im1];
nlf = ic - nl; nlf = ic - nl;
nrf = ic + 1; nrf = ic + 1;
--j; --j;
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, & dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &
b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], & b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], &
givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
j], &s[j], &work[1], info); j], &s[j], &work[1], info);
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
goto L90; goto L90;
@ -518,42 +518,42 @@ L50:
j = 0; j = 0;
i__1 = nlvl; i__1 = nlvl;
for (lvl = 1; lvl <= i__1; ++lvl) { for (lvl = 1; lvl <= i__1; ++lvl) {
lvl2 = (lvl << 1) - 1; lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on */ /* Find the first node LF and last node LL on */
/* the current level LVL. */ /* the current level LVL. */
if (lvl == 1) { if (lvl == 1) {
lf = 1; lf = 1;
ll = 1; ll = 1;
} else { } else {
i__2 = lvl - 1; i__2 = lvl - 1;
lf = pow_ii(&c__2, &i__2); lf = pow_ii(&c__2, &i__2);
ll = (lf << 1) - 1; ll = (lf << 1) - 1;
} }
i__2 = lf; i__2 = lf;
for (i__ = ll; i__ >= i__2; --i__) { for (i__ = ll; i__ >= i__2; --i__) {
im1 = i__ - 1; im1 = i__ - 1;
ic = iwork[inode + im1]; ic = iwork[inode + im1];
nl = iwork[ndiml + im1]; nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1]; nr = iwork[ndimr + im1];
nlf = ic - nl; nlf = ic - nl;
nrf = ic + 1; nrf = ic + 1;
if (i__ == ll) { if (i__ == ll) {
sqre = 0; sqre = 0;
} else { } else {
sqre = 1; sqre = 1;
} }
++j; ++j;
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[ dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[
nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], & nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], &
givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
j], &s[j], &work[1], info); j], &s[j], &work[1], info);
/* L60: */ /* L60: */
} }
/* L70: */ /* L70: */
} }
@ -564,24 +564,24 @@ L50:
ndb1 = (nd + 1) / 2; ndb1 = (nd + 1) / 2;
i__1 = nd; i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) { for (i__ = ndb1; i__ <= i__1; ++i__) {
i1 = i__ - 1; i1 = i__ - 1;
ic = iwork[inode + i1]; ic = iwork[inode + i1];
nl = iwork[ndiml + i1]; nl = iwork[ndiml + i1];
nr = iwork[ndimr + i1]; nr = iwork[ndimr + i1];
nlp1 = nl + 1; nlp1 = nl + 1;
if (i__ == nd) { if (i__ == nd) {
nrp1 = nr; nrp1 = nr;
} else { } else {
nrp1 = nr + 1; nrp1 = nr + 1;
} }
nlf = ic - nl; nlf = ic - nl;
nrf = ic + 1; nrf = ic + 1;
dgemm_((char *)"T", (char *)"N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & dgemm_((char *)"T", (char *)"N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, &
b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, ( b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, (
ftnlen)1, (ftnlen)1); ftnlen)1, (ftnlen)1);
dgemm_((char *)"T", (char *)"N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, & dgemm_((char *)"T", (char *)"N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, &
b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, ( b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, (
ftnlen)1, (ftnlen)1); ftnlen)1, (ftnlen)1);
/* L80: */ /* L80: */
} }
@ -594,5 +594,5 @@ L90:
} /* dlalsa_ */ } /* dlalsa_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

436
lib/linalg/dlalsd.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlalsd.f -- translated by f2c (version 20200916). /* fortran/dlalsd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -201,10 +201,10 @@ f"> */
/* > Osni Marques, LBNL/NERSC, USA \n */ /* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer /* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
doublereal *rcond, integer *rank, doublereal *work, integer *iwork, doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
integer *info, ftnlen uplo_len) integer *info, ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer b_dim1, b_offset, i__1, i__2; integer b_dim1, b_offset, i__1, i__2;
@ -227,44 +227,44 @@ f"> */
integer difl, difr; integer difl, difr;
doublereal rcnd; doublereal rcnd;
integer perm, nsub; integer perm, nsub;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *); doublereal *, integer *, doublereal *, doublereal *);
integer nlvl, sqre, bxst; integer nlvl, sqre, bxst;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer dcopy_(integer *, doublereal *, integer *, doublereal *, integer
*); *);
integer poles, sizei, nsize, nwork, icmpq1, icmpq2; integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *, extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dlalsa_(integer *, integer *, integer *, integer *, integer *), dlalsa_(integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dlascl_(char *, integer *, integer *, integer *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen); integer *, integer *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *, *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, ftnlen), dlacpy_(char *, integer *, doublereal *, integer *, ftnlen), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), dlartg_(doublereal *, doublereal *, doublereal *, ftnlen), dlartg_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, ftnlen), doublereal *, doublereal *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen); xerbla_(char *, integer *, ftnlen);
integer givcol; integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen); ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen); integer *, ftnlen);
doublereal orgnrm; doublereal orgnrm;
integer givnum, givptr, smlszp; integer givnum, givptr, smlszp;
@ -307,16 +307,16 @@ f"> */
*info = 0; *info = 0;
if (*n < 0) { if (*n < 0) {
*info = -3; *info = -3;
} else if (*nrhs < 1) { } else if (*nrhs < 1) {
*info = -4; *info = -4;
} else if (*ldb < 1 || *ldb < *n) { } else if (*ldb < 1 || *ldb < *n) {
*info = -8; *info = -8;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLALSD", &i__1, (ftnlen)6); xerbla_((char *)"DLALSD", &i__1, (ftnlen)6);
return 0; return 0;
} }
eps = dlamch_((char *)"Epsilon", (ftnlen)7); eps = dlamch_((char *)"Epsilon", (ftnlen)7);
@ -324,9 +324,9 @@ f"> */
/* Set up the tolerance. */ /* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.) { if (*rcond <= 0. || *rcond >= 1.) {
rcnd = eps; rcnd = eps;
} else { } else {
rcnd = *rcond; rcnd = *rcond;
} }
*rank = 0; *rank = 0;
@ -334,52 +334,52 @@ f"> */
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} else if (*n == 1) { } else if (*n == 1) {
if (d__[1] == 0.) { if (d__[1] == 0.) {
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, ( dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (
ftnlen)1); ftnlen)1);
} else { } else {
*rank = 1; *rank = 1;
dlascl_((char *)"G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ dlascl_((char *)"G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info, (ftnlen)1); b_offset], ldb, info, (ftnlen)1);
d__[1] = abs(d__[1]); d__[1] = abs(d__[1]);
} }
return 0; return 0;
} }
/* Rotate the matrix if it is lower bidiagonal. */ /* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') { if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1; i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__; d__[i__] = r__;
e[i__] = sn * d__[i__ + 1]; e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1]; d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1) { if (*nrhs == 1) {
drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
c__1, &cs, &sn); c__1, &cs, &sn);
} else { } else {
work[(i__ << 1) - 1] = cs; work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn; work[i__ * 2] = sn;
} }
/* L10: */ /* L10: */
} }
if (*nrhs > 1) { if (*nrhs > 1) {
i__1 = *nrhs; i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1; i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
cs = work[(j << 1) - 1]; cs = work[(j << 1) - 1];
sn = work[j * 2]; sn = work[j * 2];
drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
b_dim1], &c__1, &cs, &sn); b_dim1], &c__1, &cs, &sn);
/* L20: */ /* L20: */
} }
/* L30: */ /* L30: */
} }
} }
} }
/* Scale. */ /* Scale. */
@ -387,58 +387,58 @@ f"> */
nm1 = *n - 1; nm1 = *n - 1;
orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1);
if (orgnrm == 0.) { if (orgnrm == 0.) {
dlaset_((char *)"A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1); dlaset_((char *)"A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1);
return 0; return 0;
} }
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info, ( dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info, (
ftnlen)1); ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
info, (ftnlen)1); info, (ftnlen)1);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */ /* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */ /* the problem with another solver. */
if (*n <= *smlsiz) { if (*n <= *smlsiz) {
nwork = *n * *n + 1; nwork = *n * *n + 1;
dlaset_((char *)"A", n, n, &c_b6, &c_b11, &work[1], n, (ftnlen)1); dlaset_((char *)"A", n, n, &c_b6, &c_b11, &work[1], n, (ftnlen)1);
dlasdq_((char *)"U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & dlasdq_((char *)"U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
work[1], n, &b[b_offset], ldb, &work[nwork], info, (ftnlen)1); work[1], n, &b[b_offset], ldb, &work[nwork], info, (ftnlen)1);
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) { if (d__[i__] <= tol) {
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb, dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb,
(ftnlen)1); (ftnlen)1);
} else { } else {
dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
i__ + b_dim1], ldb, info, (ftnlen)1); i__ + b_dim1], ldb, info, (ftnlen)1);
++(*rank); ++(*rank);
} }
/* L40: */ /* L40: */
} }
dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
c_b6, &work[nwork], n, (ftnlen)1, (ftnlen)1); c_b6, &work[nwork], n, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"A", n, nrhs, &work[nwork], n, &b[b_offset], ldb, (ftnlen)1); dlacpy_((char *)"A", n, nrhs, &work[nwork], n, &b[b_offset], ldb, (ftnlen)1);
/* Unscale. */ /* Unscale. */
dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info, (ftnlen)1); info, (ftnlen)1);
dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1); dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
ldb, info, (ftnlen)1); ldb, info, (ftnlen)1);
return 0; return 0;
} }
/* Book-keeping and setting up some constants. */ /* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
log(2.)) + 1; log(2.)) + 1;
smlszp = *smlsiz + 1; smlszp = *smlsiz + 1;
@ -469,95 +469,95 @@ f"> */
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) { if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]); d__[i__] = d_sign(&eps, &d__[i__]);
} }
/* L50: */ /* L50: */
} }
i__1 = nm1; i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
++nsub; ++nsub;
iwork[nsub] = st; iwork[nsub] = st;
/* Subproblem found. First determine its size and then */ /* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */ /* apply divide and conquer on it. */
if (i__ < nm1) { if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */ /* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1; nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize; iwork[sizei + nsub - 1] = nsize;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) { } else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */ /* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1; nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize; iwork[sizei + nsub - 1] = nsize;
} else { } else {
/* A subproblem with E(NM1) small. This implies an */ /* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */ /* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */ /* explicitly. */
nsize = i__ - st + 1; nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize; iwork[sizei + nsub - 1] = nsize;
++nsub; ++nsub;
iwork[nsub] = *n; iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1; iwork[sizei + nsub - 1] = 1;
dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
} }
st1 = st - 1; st1 = st - 1;
if (nsize == 1) { if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved */ /* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */ /* explicitly. */
dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) { } else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by DLASDQ. */ /* This is a small subproblem and is solved by DLASDQ. */
dlaset_((char *)"A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], dlaset_((char *)"A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n, (ftnlen)1); n, (ftnlen)1);
dlasdq_((char *)"U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ dlasdq_((char *)"U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
st], &work[vt + st1], n, &work[nwork], n, &b[st + st], &work[vt + st1], n, &work[nwork], n, &b[st +
b_dim1], ldb, &work[nwork], info, (ftnlen)1); b_dim1], ldb, &work[nwork], info, (ftnlen)1);
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
dlacpy_((char *)"A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + dlacpy_((char *)"A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
st1], n, (ftnlen)1); st1], n, (ftnlen)1);
} else { } else {
/* A large problem. Solve it using divide and conquer. */ /* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
work[u + st1], n, &work[vt + st1], &iwork[k + st1], & work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
work[difl + st1], &work[difr + st1], &work[z__ + st1], work[difl + st1], &work[difr + st1], &work[z__ + st1],
&work[poles + st1], &iwork[givptr + st1], &iwork[ &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + givcol + st1], n, &iwork[perm + st1], &work[givnum +
st1], &work[c__ + st1], &work[s + st1], &work[nwork], st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info); &iwork[iwk], info);
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
bxst = bx + st1; bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
work[bxst], n, &work[u + st1], n, &work[vt + st1], & work[bxst], n, &work[u + st1], n, &work[vt + st1], &
iwork[k + st1], &work[difl + st1], &work[difr + st1], iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr + &work[z__ + st1], &work[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], & st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
work[givnum + st1], &work[c__ + st1], &work[s + st1], work[givnum + st1], &work[c__ + st1], &work[s + st1],
&work[nwork], &iwork[iwk], info); &work[nwork], &iwork[iwk], info);
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
} }
st = i__ + 1; st = i__ + 1;
} }
/* L60: */ /* L60: */
} }
@ -571,15 +571,15 @@ f"> */
/* Some of the elements in D can be negative because 1-by-1 */ /* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */ /* subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol) { if ((d__1 = d__[i__], abs(d__1)) <= tol) {
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n, ( dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n, (
ftnlen)1); ftnlen)1);
} else { } else {
++(*rank); ++(*rank);
dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info, (ftnlen)1); bx + i__ - 1], n, info, (ftnlen)1);
} }
d__[i__] = (d__1 = d__[i__], abs(d__1)); d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */ /* L70: */
} }
@ -588,38 +588,38 @@ f"> */
icmpq2 = 1; icmpq2 = 1;
i__1 = nsub; i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__]; st = iwork[i__];
st1 = st - 1; st1 = st - 1;
nsize = iwork[sizei + i__ - 1]; nsize = iwork[sizei + i__ - 1];
bxst = bx + st1; bxst = bx + st1;
if (nsize == 1) { if (nsize == 1) {
dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
} else if (nsize <= *smlsiz) { } else if (nsize <= *smlsiz) {
dgemm_((char *)"T", (char *)"N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, dgemm_((char *)"T", (char *)"N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
&work[bxst], n, &c_b6, &b[st + b_dim1], ldb, (ftnlen)1, ( &work[bxst], n, &c_b6, &b[st + b_dim1], ldb, (ftnlen)1, (
ftnlen)1); ftnlen)1);
} else { } else {
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
k + st1], &work[difl + st1], &work[difr + st1], &work[z__ k + st1], &work[difl + st1], &work[difr + st1], &work[z__
+ st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
iwk], info); iwk], info);
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
} }
/* L80: */ /* L80: */
} }
/* Unscale and sort the singular values. */ /* Unscale and sort the singular values. */
dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info, ( dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info, (
ftnlen)1); ftnlen)1);
dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1); dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1); info, (ftnlen)1);
return 0; return 0;
@ -628,5 +628,5 @@ f"> */
} /* dlalsd_ */ } /* dlalsd_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

78
lib/linalg/dlamrg.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlamrg.f -- translated by f2c (version 20200916). /* fortran/dlamrg.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -15,7 +15,7 @@ extern "C" {
#endif #endif
#include "lmp_f2c.h" #include "lmp_f2c.h"
/* > \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a /* > \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a
single set sorted in ascending order. */ single set sorted in ascending order. */
/* =========== DOCUMENTATION =========== */ /* =========== DOCUMENTATION =========== */
@ -116,8 +116,8 @@ f"> */
/* > \ingroup auxOTHERcomputational */ /* > \ingroup auxOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer /* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer
*dtrd1, integer *dtrd2, integer *index) *dtrd1, integer *dtrd2, integer *index)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -149,50 +149,50 @@ f"> */
n1sv = *n1; n1sv = *n1;
n2sv = *n2; n2sv = *n2;
if (*dtrd1 > 0) { if (*dtrd1 > 0) {
ind1 = 1; ind1 = 1;
} else { } else {
ind1 = *n1; ind1 = *n1;
} }
if (*dtrd2 > 0) { if (*dtrd2 > 0) {
ind2 = *n1 + 1; ind2 = *n1 + 1;
} else { } else {
ind2 = *n1 + *n2; ind2 = *n1 + *n2;
} }
i__ = 1; i__ = 1;
/* while ( (N1SV > 0) & (N2SV > 0) ) */ /* while ( (N1SV > 0) & (N2SV > 0) ) */
L10: L10:
if (n1sv > 0 && n2sv > 0) { if (n1sv > 0 && n2sv > 0) {
if (a[ind1] <= a[ind2]) { if (a[ind1] <= a[ind2]) {
index[i__] = ind1; index[i__] = ind1;
++i__; ++i__;
ind1 += *dtrd1; ind1 += *dtrd1;
--n1sv; --n1sv;
} else { } else {
index[i__] = ind2; index[i__] = ind2;
++i__; ++i__;
ind2 += *dtrd2; ind2 += *dtrd2;
--n2sv; --n2sv;
} }
goto L10; goto L10;
} }
/* end while */ /* end while */
if (n1sv == 0) { if (n1sv == 0) {
i__1 = n2sv; i__1 = n2sv;
for (n1sv = 1; n1sv <= i__1; ++n1sv) { for (n1sv = 1; n1sv <= i__1; ++n1sv) {
index[i__] = ind2; index[i__] = ind2;
++i__; ++i__;
ind2 += *dtrd2; ind2 += *dtrd2;
/* L20: */ /* L20: */
} }
} else { } else {
/* N2SV .EQ. 0 */ /* N2SV .EQ. 0 */
i__1 = n1sv; i__1 = n1sv;
for (n2sv = 1; n2sv <= i__1; ++n2sv) { for (n2sv = 1; n2sv <= i__1; ++n2sv) {
index[i__] = ind1; index[i__] = ind1;
++i__; ++i__;
ind1 += *dtrd1; ind1 += *dtrd1;
/* L30: */ /* L30: */
} }
} }
return 0; return 0;
@ -202,5 +202,5 @@ L10:
} /* dlamrg_ */ } /* dlamrg_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

130
lib/linalg/dlange.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlange.f -- translated by f2c (version 20200916). /* fortran/dlange.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -19,7 +19,7 @@ extern "C" {
static integer c__1 = 1; static integer c__1 = 1;
/* > \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute /* > \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute
value of any element of a general rectangular matrix. */ value of any element of a general rectangular matrix. */
/* =========== DOCUMENTATION =========== */ /* =========== DOCUMENTATION =========== */
@ -135,8 +135,8 @@ f"> */
/* > \ingroup doubleGEauxiliary */ /* > \ingroup doubleGEauxiliary */
/* ===================================================================== */ /* ===================================================================== */
doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
*lda, doublereal *work, ftnlen norm_len) *lda, doublereal *work, ftnlen norm_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -151,8 +151,8 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal value; doublereal value;
extern logical disnan_(doublereal *); extern logical disnan_(doublereal *);
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *); doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -186,83 +186,83 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
/* Function Body */ /* Function Body */
if (min(*m,*n) == 0) { if (min(*m,*n) == 0) {
value = 0.; value = 0.;
} else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */ /* Find max(abs(A(i,j))). */
value = 0.; value = 0.;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
if (value < temp || disnan_(&temp)) { if (value < temp || disnan_(&temp)) {
value = temp; value = temp;
} }
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *) } else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') { norm == '1') {
/* Find norm1(A). */ /* Find norm1(A). */
value = 0.; value = 0.;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
sum = 0.; sum = 0.;
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L30: */ /* L30: */
} }
if (value < sum || disnan_(&sum)) { if (value < sum || disnan_(&sum)) {
value = sum; value = sum;
} }
/* L40: */ /* L40: */
} }
} else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */ /* Find normI(A). */
i__1 = *m; i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.; work[i__] = 0.;
/* L50: */ /* L50: */
} }
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L60: */ /* L60: */
} }
/* L70: */ /* L70: */
} }
value = 0.; value = 0.;
i__1 = *m; i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
temp = work[i__]; temp = work[i__];
if (value < temp || disnan_(&temp)) { if (value < temp || disnan_(&temp)) {
value = temp; value = temp;
} }
/* L80: */ /* L80: */
} }
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", ( } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (
ftnlen)1, (ftnlen)1)) { ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */ /* Find normF(A). */
scale = 0.; scale = 0.;
sum = 1.; sum = 1.;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */ /* L90: */
} }
value = scale * sqrt(sum); value = scale * sqrt(sum);
} }
ret_val = value; ret_val = value;
@ -273,5 +273,5 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
} /* dlange_ */ } /* dlange_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

106
lib/linalg/dlanst.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlanst.f -- translated by f2c (version 20200916). /* fortran/dlanst.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -121,8 +121,8 @@ f"> */
/* > \ingroup OTHERauxiliary */ /* > \ingroup OTHERauxiliary */
/* ===================================================================== */ /* ===================================================================== */
doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
ftnlen norm_len) ftnlen norm_len)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -137,8 +137,8 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal anorm; doublereal anorm;
extern logical disnan_(doublereal *); extern logical disnan_(doublereal *);
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *); doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -170,61 +170,61 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
/* Function Body */ /* Function Body */
if (*n <= 0) { if (*n <= 0) {
anorm = 0.; anorm = 0.;
} else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */ /* Find max(abs(A(i,j))). */
anorm = (d__1 = d__[*n], abs(d__1)); anorm = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1; i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
sum = (d__1 = d__[i__], abs(d__1)); sum = (d__1 = d__[i__], abs(d__1));
if (anorm < sum || disnan_(&sum)) { if (anorm < sum || disnan_(&sum)) {
anorm = sum; anorm = sum;
} }
sum = (d__1 = e[i__], abs(d__1)); sum = (d__1 = e[i__], abs(d__1));
if (anorm < sum || disnan_(&sum)) { if (anorm < sum || disnan_(&sum)) {
anorm = sum; anorm = sum;
} }
/* L10: */ /* L10: */
} }
} else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *) } else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1' || lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { norm == '1' || lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
/* Find norm1(A). */ /* Find norm1(A). */
if (*n == 1) { if (*n == 1) {
anorm = abs(d__[1]); anorm = abs(d__[1]);
} else { } else {
anorm = abs(d__[1]) + abs(e[1]); anorm = abs(d__[1]) + abs(e[1]);
sum = (d__1 = e[*n - 1], abs(d__1)) + (d__2 = d__[*n], abs(d__2)); sum = (d__1 = e[*n - 1], abs(d__1)) + (d__2 = d__[*n], abs(d__2));
if (anorm < sum || disnan_(&sum)) { if (anorm < sum || disnan_(&sum)) {
anorm = sum; anorm = sum;
} }
i__1 = *n - 1; i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2) sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2)
) + (d__3 = e[i__ - 1], abs(d__3)); ) + (d__3 = e[i__ - 1], abs(d__3));
if (anorm < sum || disnan_(&sum)) { if (anorm < sum || disnan_(&sum)) {
anorm = sum; anorm = sum;
} }
/* L20: */ /* L20: */
} }
} }
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", ( } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (
ftnlen)1, (ftnlen)1)) { ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */ /* Find normF(A). */
scale = 0.; scale = 0.;
sum = 1.; sum = 1.;
if (*n > 1) { if (*n > 1) {
i__1 = *n - 1; i__1 = *n - 1;
dlassq_(&i__1, &e[1], &c__1, &scale, &sum); dlassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2; sum *= 2;
} }
dlassq_(n, &d__[1], &c__1, &scale, &sum); dlassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum); anorm = scale * sqrt(sum);
} }
ret_val = anorm; ret_val = anorm;
@ -235,5 +235,5 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
} /* dlanst_ */ } /* dlanst_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

194
lib/linalg/dlansy.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlansy.f -- translated by f2c (version 20200916). /* fortran/dlansy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -143,8 +143,8 @@ f"> */
/* > \ingroup doubleSYauxiliary */ /* > \ingroup doubleSYauxiliary */
/* ===================================================================== */ /* ===================================================================== */
doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
*lda, doublereal *work, ftnlen norm_len, ftnlen uplo_len) *lda, doublereal *work, ftnlen norm_len, ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -159,8 +159,8 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal value; doublereal value;
extern logical disnan_(doublereal *); extern logical disnan_(doublereal *);
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *); doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -194,115 +194,115 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
/* Function Body */ /* Function Body */
if (*n == 0) { if (*n == 0) {
value = 0.; value = 0.;
} else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */ /* Find max(abs(A(i,j))). */
value = 0.; value = 0.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j; i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); sum = (d__1 = a[i__ + j * a_dim1], abs(d__1));
if (value < sum || disnan_(&sum)) { if (value < sum || disnan_(&sum)) {
value = sum; value = sum;
} }
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *n; i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) { for (i__ = j; i__ <= i__2; ++i__) {
sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); sum = (d__1 = a[i__ + j * a_dim1], abs(d__1));
if (value < sum || disnan_(&sum)) { if (value < sum || disnan_(&sum)) {
value = sum; value = sum;
} }
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
} }
} else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", ( } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", (
ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') { ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is symmetric). */ /* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.; value = 0.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
sum = 0.; sum = 0.;
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
sum += absa; sum += absa;
work[i__] += absa; work[i__] += absa;
/* L50: */ /* L50: */
} }
work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1)); work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1));
/* L60: */ /* L60: */
} }
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
sum = work[i__]; sum = work[i__];
if (value < sum || disnan_(&sum)) { if (value < sum || disnan_(&sum)) {
value = sum; value = sum;
} }
/* L70: */ /* L70: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.; work[i__] = 0.;
/* L80: */ /* L80: */
} }
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1)); sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1));
i__2 = *n; i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
sum += absa; sum += absa;
work[i__] += absa; work[i__] += absa;
/* L90: */ /* L90: */
} }
if (value < sum || disnan_(&sum)) { if (value < sum || disnan_(&sum)) {
value = sum; value = sum;
} }
/* L100: */ /* L100: */
} }
} }
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", ( } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (
ftnlen)1, (ftnlen)1)) { ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */ /* Find normF(A). */
scale = 0.; scale = 0.;
sum = 1.; sum = 1.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n; i__1 = *n;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
i__2 = j - 1; i__2 = j - 1;
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L110: */ /* L110: */
} }
} else { } else {
i__1 = *n - 1; i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *n - j; i__2 = *n - j;
dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
/* L120: */ /* L120: */
} }
} }
sum *= 2; sum *= 2;
i__1 = *lda + 1; i__1 = *lda + 1;
dlassq_(n, &a[a_offset], &i__1, &scale, &sum); dlassq_(n, &a[a_offset], &i__1, &scale, &sum);
value = scale * sqrt(sum); value = scale * sqrt(sum);
} }
ret_val = value; ret_val = value;
@ -313,5 +313,5 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
} /* dlansy_ */ } /* dlansy_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

40
lib/linalg/dlapy2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlapy2.f -- translated by f2c (version 20200916). /* fortran/dlapy2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -119,25 +119,25 @@ doublereal dlapy2_(doublereal *x, doublereal *y)
x_is_nan__ = disnan_(x); x_is_nan__ = disnan_(x);
y_is_nan__ = disnan_(y); y_is_nan__ = disnan_(y);
if (x_is_nan__) { if (x_is_nan__) {
ret_val = *x; ret_val = *x;
} }
if (y_is_nan__) { if (y_is_nan__) {
ret_val = *y; ret_val = *y;
} }
hugeval = dlamch_((char *)"Overflow", (ftnlen)8); hugeval = dlamch_((char *)"Overflow", (ftnlen)8);
if (! (x_is_nan__ || y_is_nan__)) { if (! (x_is_nan__ || y_is_nan__)) {
xabs = abs(*x); xabs = abs(*x);
yabs = abs(*y); yabs = abs(*y);
w = max(xabs,yabs); w = max(xabs,yabs);
z__ = min(xabs,yabs); z__ = min(xabs,yabs);
if (z__ == 0. || w > hugeval) { if (z__ == 0. || w > hugeval) {
ret_val = w; ret_val = w;
} else { } else {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = z__ / w; d__1 = z__ / w;
ret_val = w * sqrt(d__1 * d__1 + 1.); ret_val = w * sqrt(d__1 * d__1 + 1.);
} }
} }
return ret_val; return ret_val;
@ -146,5 +146,5 @@ doublereal dlapy2_(doublereal *x, doublereal *y)
} /* dlapy2_ */ } /* dlapy2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

26
lib/linalg/dlapy3.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlapy3.f -- translated by f2c (version 20200916). /* fortran/dlapy3.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -128,15 +128,15 @@ doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__)
/* W can be zero for max(0,nan,0) */ /* W can be zero for max(0,nan,0) */
/* adding all three entries together will make sure */ /* adding all three entries together will make sure */
/* NaN will not disappear. */ /* NaN will not disappear. */
ret_val = xabs + yabs + zabs; ret_val = xabs + yabs + zabs;
} else { } else {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = xabs / w; d__1 = xabs / w;
/* Computing 2nd power */ /* Computing 2nd power */
d__2 = yabs / w; d__2 = yabs / w;
/* Computing 2nd power */ /* Computing 2nd power */
d__3 = zabs / w; d__3 = zabs / w;
ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3);
} }
return ret_val; return ret_val;
@ -145,5 +145,5 @@ doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__)
} /* dlapy3_ */ } /* dlapy3_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

102
lib/linalg/dlarf.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlarf.f -- translated by f2c (version 20200916). /* fortran/dlarf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -147,8 +147,8 @@ static integer c__1 = 1;
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v, /* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,
integer *incv, doublereal *tau, doublereal *c__, integer *ldc, integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
doublereal *work, ftnlen side_len) doublereal *work, ftnlen side_len)
{ {
/* System generated locals */ /* System generated locals */
integer c_dim1, c_offset; integer c_dim1, c_offset;
@ -157,16 +157,16 @@ static integer c__1 = 1;
/* Local variables */ /* Local variables */
integer i__; integer i__;
logical applyleft; logical applyleft;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *); integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *, extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen); doublereal *, doublereal *, integer *, ftnlen);
integer lastc, lastv; integer lastc, lastv;
extern integer iladlc_(integer *, integer *, doublereal *, integer *), extern integer iladlc_(integer *, integer *, doublereal *, integer *),
iladlr_(integer *, integer *, doublereal *, integer *); iladlr_(integer *, integer *, doublereal *, integer *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -204,28 +204,28 @@ static integer c__1 = 1;
if (*tau != 0.) { if (*tau != 0.) {
/* Set up variables for scanning V. LASTV begins pointing to the end */ /* Set up variables for scanning V. LASTV begins pointing to the end */
/* of V. */ /* of V. */
if (applyleft) { if (applyleft) {
lastv = *m; lastv = *m;
} else { } else {
lastv = *n; lastv = *n;
} }
if (*incv > 0) { if (*incv > 0) {
i__ = (lastv - 1) * *incv + 1; i__ = (lastv - 1) * *incv + 1;
} else { } else {
i__ = 1; i__ = 1;
} }
/* Look for the last non-zero row in V. */ /* Look for the last non-zero row in V. */
while(lastv > 0 && v[i__] == 0.) { while(lastv > 0 && v[i__] == 0.) {
--lastv; --lastv;
i__ -= *incv; i__ -= *incv;
} }
if (applyleft) { if (applyleft) {
/* Scan for the last non-zero column in C(1:lastv,:). */ /* Scan for the last non-zero column in C(1:lastv,:). */
lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
} else { } else {
/* Scan for the last non-zero row in C(:,1:lastv). */ /* Scan for the last non-zero row in C(:,1:lastv). */
lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
} }
} }
/* Note that lastc.eq.0 renders the BLAS operations null; no special */ /* Note that lastc.eq.0 renders the BLAS operations null; no special */
/* case is needed at this level. */ /* case is needed at this level. */
@ -233,36 +233,36 @@ static integer c__1 = 1;
/* Form H * C */ /* Form H * C */
if (lastv > 0) { if (lastv > 0) {
/* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) */ /* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) */
dgemv_((char *)"Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, & dgemv_((char *)"Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)9); v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)9);
/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T */ /* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T */
d__1 = -(*tau); d__1 = -(*tau);
dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[ dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[
c_offset], ldc); c_offset], ldc);
} }
} else { } else {
/* Form C * H */ /* Form C * H */
if (lastv > 0) { if (lastv > 0) {
/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ /* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
dgemv_((char *)"No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, dgemv_((char *)"No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc,
&v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)12); &v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)12);
/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T */ /* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T */
d__1 = -(*tau); d__1 = -(*tau);
dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[ dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
c_offset], ldc); c_offset], ldc);
} }
} }
return 0; return 0;
@ -271,5 +271,5 @@ static integer c__1 = 1;
} /* dlarf_ */ } /* dlarf_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

648
lib/linalg/dlarfb.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlarfb.f -- translated by f2c (version 20200916). /* fortran/dlarfb.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -219,25 +219,25 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char * /* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, doublereal *v, integer * storev, integer *m, integer *n, integer *k, doublereal *v, integer *
ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc,
doublereal *work, integer *ldwork, ftnlen side_len, ftnlen trans_len, doublereal *work, integer *ldwork, ftnlen side_len, ftnlen trans_len,
ftnlen direct_len, ftnlen storev_len) ftnlen direct_len, ftnlen storev_len)
{ {
/* System generated locals */ /* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2; work_offset, i__1, i__2;
/* Local variables */ /* Local variables */
integer i__, j; integer i__, j;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dtrmm_(char *, char *, char *, char *, doublereal *, integer *), dtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
char transt[1]; char transt[1];
@ -280,24 +280,24 @@ f"> */
/* Function Body */ /* Function Body */
if (*m <= 0 || *n <= 0) { if (*m <= 0 || *n <= 0) {
return 0; return 0;
} }
if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) {
*(unsigned char *)transt = 'T'; *(unsigned char *)transt = 'T';
} else { } else {
*(unsigned char *)transt = 'N'; *(unsigned char *)transt = 'N';
} }
if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
/* Let V = ( V1 ) (first K rows) */ /* Let V = ( V1 ) (first K rows) */
/* ( V2 ) */ /* ( V2 ) */
/* where V1 is unit lower triangular. */ /* where V1 is unit lower triangular. */
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Form H * C or H**T * C where C = ( C1 ) */ /* Form H * C or H**T * C where C = ( C1 ) */
/* ( C2 ) */ /* ( C2 ) */
@ -306,67 +306,67 @@ f"> */
/* W := C1**T */ /* W := C1**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
&c__1); &c__1);
/* L10: */ /* L10: */
} }
/* W := W * V1 */ /* W := W * V1 */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, ( &v[v_offset], ldv, &work[work_offset], ldwork, (
ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
if (*m > *k) { if (*m > *k) {
/* W := W + C2**T * V2 */ /* W := W + C2**T * V2 */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, & dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, &
c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1],
ldv, &c_b14, &work[work_offset], ldwork, (ftnlen) ldv, &c_b14, &work[work_offset], ldwork, (ftnlen)
9, (ftnlen)12); 9, (ftnlen)12);
} }
/* W := W * T**T or W * T */ /* W := W * T**T or W * T */
dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - V * W**T */ /* C := C - V * W**T */
if (*m > *k) { if (*m > *k) {
/* C2 := C2 - V2 * W**T */ /* C2 := C2 - V2 * W**T */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, & dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &
v[*k + 1 + v_dim1], ldv, &work[work_offset], v[*k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, ( ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, (
ftnlen)12, (ftnlen)9); ftnlen)12, (ftnlen)9);
} }
/* W := W * V1**T */ /* W := W * V1**T */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen)
5, (ftnlen)5, (ftnlen)9, (ftnlen)4); 5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
/* C1 := C1 - W**T */ /* C1 := C1 - W**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
/* L20: */ /* L20: */
} }
/* L30: */ /* L30: */
} }
} else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
/* Form C * H or C * H**T where C = ( C1 C2 ) */ /* Form C * H or C * H**T where C = ( C1 C2 ) */
@ -374,74 +374,74 @@ f"> */
/* W := C1 */ /* W := C1 */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1); work_dim1 + 1], &c__1);
/* L40: */ /* L40: */
} }
/* W := W * V1 */ /* W := W * V1 */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, ( &v[v_offset], ldv, &work[work_offset], ldwork, (
ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
if (*n > *k) { if (*n > *k) {
/* W := W + C2 * V2 */ /* W := W + C2 * V2 */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, & dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &
c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k +
1 + v_dim1], ldv, &c_b14, &work[work_offset], 1 + v_dim1], ldv, &c_b14, &work[work_offset],
ldwork, (ftnlen)12, (ftnlen)12); ldwork, (ftnlen)12, (ftnlen)12);
} }
/* W := W * T or W * T**T */ /* W := W * T or W * T**T */
dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - W * V**T */ /* C := C - W * V**T */
if (*n > *k) { if (*n > *k) {
/* C2 := C2 - W * V2**T */ /* C2 := C2 - W * V2**T */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, & dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, &
work[work_offset], ldwork, &v[*k + 1 + v_dim1], work[work_offset], ldwork, &v[*k + 1 + v_dim1],
ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, ( ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, (
ftnlen)12, (ftnlen)9); ftnlen)12, (ftnlen)9);
} }
/* W := W * V1**T */ /* W := W * V1**T */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen)
5, (ftnlen)5, (ftnlen)9, (ftnlen)4); 5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
/* C1 := C1 - W */ /* C1 := C1 - W */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
/* L50: */ /* L50: */
} }
/* L60: */ /* L60: */
} }
} }
} else { } else {
/* Let V = ( V1 ) */ /* Let V = ( V1 ) */
/* ( V2 ) (last K rows) */ /* ( V2 ) (last K rows) */
/* where V2 is unit upper triangular. */ /* where V2 is unit upper triangular. */
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Form H * C or H**T * C where C = ( C1 ) */ /* Form H * C or H**T * C where C = ( C1 ) */
/* ( C2 ) */ /* ( C2 ) */
@ -450,67 +450,67 @@ f"> */
/* W := C2**T */ /* W := C2**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
work_dim1 + 1], &c__1); work_dim1 + 1], &c__1);
/* L70: */ /* L70: */
} }
/* W := W * V2 */ /* W := W * V2 */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14,
&v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
if (*m > *k) { if (*m > *k) {
/* W := W + C1**T * V1 */ /* W := W + C1**T * V1 */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, & dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, &
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
work[work_offset], ldwork, (ftnlen)9, (ftnlen)12); work[work_offset], ldwork, (ftnlen)9, (ftnlen)12);
} }
/* W := W * T**T or W * T */ /* W := W * T**T or W * T */
dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - V * W**T */ /* C := C - V * W**T */
if (*m > *k) { if (*m > *k) {
/* C1 := C1 - V1 * W**T */ /* C1 := C1 - V1 * W**T */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, & dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &
v[v_offset], ldv, &work[work_offset], ldwork, & v[v_offset], ldv, &work[work_offset], ldwork, &
c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9) c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9)
; ;
} }
/* W := W * V2**T */ /* W := W * V2**T */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, &
v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
/* C2 := C2 - W**T */ /* C2 := C2 - W**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
work_dim1]; work_dim1];
/* L80: */ /* L80: */
} }
/* L90: */ /* L90: */
} }
} else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
/* Form C * H or C * H**T where C = ( C1 C2 ) */ /* Form C * H or C * H**T where C = ( C1 C2 ) */
@ -518,77 +518,77 @@ f"> */
/* W := C2 */ /* W := C2 */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
j * work_dim1 + 1], &c__1); j * work_dim1 + 1], &c__1);
/* L100: */ /* L100: */
} }
/* W := W * V2 */ /* W := W * V2 */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14,
&v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
if (*n > *k) { if (*n > *k) {
/* W := W + C1 * V1 */ /* W := W + C1 * V1 */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, & dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &
c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b14, &work[work_offset], ldwork, (ftnlen)12, ( c_b14, &work[work_offset], ldwork, (ftnlen)12, (
ftnlen)12); ftnlen)12);
} }
/* W := W * T or W * T**T */ /* W := W * T or W * T**T */
dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - W * V**T */ /* C := C - W * V**T */
if (*n > *k) { if (*n > *k) {
/* C1 := C1 - W * V1**T */ /* C1 := C1 - W * V1**T */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, & dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, &
work[work_offset], ldwork, &v[v_offset], ldv, & work[work_offset], ldwork, &v[v_offset], ldv, &
c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9) c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9)
; ;
} }
/* W := W * V2**T */ /* W := W * V2**T */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, &
v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
/* C2 := C2 - W */ /* C2 := C2 - W */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
work_dim1]; work_dim1];
/* L110: */ /* L110: */
} }
/* L120: */ /* L120: */
} }
} }
} }
} else if (lsame_(storev, (char *)"R", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(storev, (char *)"R", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
/* Let V = ( V1 V2 ) (V1: first K columns) */ /* Let V = ( V1 V2 ) (V1: first K columns) */
/* where V1 is unit upper triangular. */ /* where V1 is unit upper triangular. */
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Form H * C or H**T * C where C = ( C1 ) */ /* Form H * C or H**T * C where C = ( C1 ) */
/* ( C2 ) */ /* ( C2 ) */
@ -597,67 +597,67 @@ f"> */
/* W := C1**T */ /* W := C1**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
&c__1); &c__1);
/* L130: */ /* L130: */
} }
/* W := W * V1**T */ /* W := W * V1**T */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen)
5, (ftnlen)5, (ftnlen)9, (ftnlen)4); 5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
if (*m > *k) { if (*m > *k) {
/* W := W + C2**T * V2**T */ /* W := W + C2**T * V2**T */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, & dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, &
c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 +
1], ldv, &c_b14, &work[work_offset], ldwork, ( 1], ldv, &c_b14, &work[work_offset], ldwork, (
ftnlen)9, (ftnlen)9); ftnlen)9, (ftnlen)9);
} }
/* W := W * T**T or W * T */ /* W := W * T**T or W * T */
dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - V**T * W**T */ /* C := C - V**T * W**T */
if (*m > *k) { if (*m > *k) {
/* C2 := C2 - V2**T * W**T */ /* C2 := C2 - V2**T * W**T */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[( dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[(
*k + 1) * v_dim1 + 1], ldv, &work[work_offset], *k + 1) * v_dim1 + 1], ldv, &work[work_offset],
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, ( ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, (
ftnlen)9, (ftnlen)9); ftnlen)9, (ftnlen)9);
} }
/* W := W * V1 */ /* W := W * V1 */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, ( &v[v_offset], ldv, &work[work_offset], ldwork, (
ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
/* C1 := C1 - W**T */ /* C1 := C1 - W**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
/* L140: */ /* L140: */
} }
/* L150: */ /* L150: */
} }
} else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
/* Form C * H or C * H**T where C = ( C1 C2 ) */ /* Form C * H or C * H**T where C = ( C1 C2 ) */
@ -665,74 +665,74 @@ f"> */
/* W := C1 */ /* W := C1 */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1); work_dim1 + 1], &c__1);
/* L160: */ /* L160: */
} }
/* W := W * V1**T */ /* W := W * V1**T */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen)
5, (ftnlen)5, (ftnlen)9, (ftnlen)4); 5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
if (*n > *k) { if (*n > *k) {
/* W := W + C2 * V2**T */ /* W := W + C2 * V2**T */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, & dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, &
c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) *
v_dim1 + 1], ldv, &c_b14, &work[work_offset], v_dim1 + 1], ldv, &c_b14, &work[work_offset],
ldwork, (ftnlen)12, (ftnlen)9); ldwork, (ftnlen)12, (ftnlen)9);
} }
/* W := W * T or W * T**T */ /* W := W * T or W * T**T */
dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - W * V */ /* C := C - W * V */
if (*n > *k) { if (*n > *k) {
/* C2 := C2 - W * V2 */ /* C2 := C2 - W * V2 */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, & dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &
c_b25, &work[work_offset], ldwork, &v[(*k + 1) * c_b25, &work[work_offset], ldwork, &v[(*k + 1) *
v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1
+ 1], ldc, (ftnlen)12, (ftnlen)12); + 1], ldc, (ftnlen)12, (ftnlen)12);
} }
/* W := W * V1 */ /* W := W * V1 */
dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, ( &v[v_offset], ldv, &work[work_offset], ldwork, (
ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
/* C1 := C1 - W */ /* C1 := C1 - W */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
/* L170: */ /* L170: */
} }
/* L180: */ /* L180: */
} }
} }
} else { } else {
/* Let V = ( V1 V2 ) (V2: last K columns) */ /* Let V = ( V1 V2 ) (V2: last K columns) */
/* where V2 is unit lower triangular. */ /* where V2 is unit lower triangular. */
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Form H * C or H**T * C where C = ( C1 ) */ /* Form H * C or H**T * C where C = ( C1 ) */
/* ( C2 ) */ /* ( C2 ) */
@ -741,67 +741,67 @@ f"> */
/* W := C2**T */ /* W := C2**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
work_dim1 + 1], &c__1); work_dim1 + 1], &c__1);
/* L190: */ /* L190: */
} }
/* W := W * V2**T */ /* W := W * V2**T */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, &
v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
, ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); , ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
if (*m > *k) { if (*m > *k) {
/* W := W + C1**T * V1**T */ /* W := W + C1**T * V1**T */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, & dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, &
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
work[work_offset], ldwork, (ftnlen)9, (ftnlen)9); work[work_offset], ldwork, (ftnlen)9, (ftnlen)9);
} }
/* W := W * T**T or W * T */ /* W := W * T**T or W * T */
dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - V**T * W**T */ /* C := C - V**T * W**T */
if (*m > *k) { if (*m > *k) {
/* C1 := C1 - V1**T * W**T */ /* C1 := C1 - V1**T * W**T */
i__1 = *m - *k; i__1 = *m - *k;
dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[ dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[
v_offset], ldv, &work[work_offset], ldwork, & v_offset], ldv, &work[work_offset], ldwork, &
c_b14, &c__[c_offset], ldc, (ftnlen)9, (ftnlen)9); c_b14, &c__[c_offset], ldc, (ftnlen)9, (ftnlen)9);
} }
/* W := W * V2 */ /* W := W * V2 */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14,
&v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)
12, (ftnlen)4); 12, (ftnlen)4);
/* C2 := C2 - W**T */ /* C2 := C2 - W**T */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
work_dim1]; work_dim1];
/* L200: */ /* L200: */
} }
/* L210: */ /* L210: */
} }
} else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
/* Form C * H or C * H' where C = ( C1 C2 ) */ /* Form C * H or C * H' where C = ( C1 C2 ) */
@ -809,70 +809,70 @@ f"> */
/* W := C2 */ /* W := C2 */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
j * work_dim1 + 1], &c__1); j * work_dim1 + 1], &c__1);
/* L220: */ /* L220: */
} }
/* W := W * V2**T */ /* W := W * V2**T */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, &
v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
, ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); , ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4);
if (*n > *k) { if (*n > *k) {
/* W := W + C1 * V1**T */ /* W := W + C1 * V1**T */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, & dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, &
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
work[work_offset], ldwork, (ftnlen)12, (ftnlen)9); work[work_offset], ldwork, (ftnlen)12, (ftnlen)9);
} }
/* W := W * T or W * T**T */ /* W := W * T or W * T**T */
dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[ dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5,
(ftnlen)5, (ftnlen)1, (ftnlen)8); (ftnlen)5, (ftnlen)1, (ftnlen)8);
/* C := C - W * V */ /* C := C - W * V */
if (*n > *k) { if (*n > *k) {
/* C1 := C1 - W * V1 */ /* C1 := C1 - W * V1 */
i__1 = *n - *k; i__1 = *n - *k;
dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, & dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &
c_b25, &work[work_offset], ldwork, &v[v_offset], c_b25, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b14, &c__[c_offset], ldc, (ftnlen)12, ( ldv, &c_b14, &c__[c_offset], ldc, (ftnlen)12, (
ftnlen)12); ftnlen)12);
} }
/* W := W * V2 */ /* W := W * V2 */
dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14,
&v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)
12, (ftnlen)4); 12, (ftnlen)4);
/* C1 := C1 - W */ /* C1 := C1 - W */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
work_dim1]; work_dim1];
/* L230: */ /* L230: */
} }
/* L240: */ /* L240: */
} }
} }
} }
} }
return 0; return 0;
@ -882,5 +882,5 @@ f"> */
} /* dlarfb_ */ } /* dlarfb_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

90
lib/linalg/dlarfg.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlarfg.f -- translated by f2c (version 20200916). /* fortran/dlarfg.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -122,8 +122,8 @@ f"> */
/* > \ingroup doubleOTHERauxiliary */ /* > \ingroup doubleOTHERauxiliary */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, /* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x,
integer *incx, doublereal *tau) integer *incx, doublereal *tau)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -136,11 +136,11 @@ f"> */
integer j, knt; integer j, knt;
doublereal beta; doublereal beta;
extern doublereal dnrm2_(integer *, doublereal *, integer *); extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *); integer *);
doublereal xnorm; doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen); ftnlen);
doublereal safmin, rsafmn; doublereal safmin, rsafmn;
@ -172,8 +172,8 @@ f"> */
/* Function Body */ /* Function Body */
if (*n <= 1) { if (*n <= 1) {
*tau = 0.; *tau = 0.;
return 0; return 0;
} }
i__1 = *n - 1; i__1 = *n - 1;
@ -183,50 +183,50 @@ f"> */
/* H = I */ /* H = I */
*tau = 0.; *tau = 0.;
} else { } else {
/* general case */ /* general case */
d__1 = dlapy2_(alpha, &xnorm); d__1 = dlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha); beta = -d_sign(&d__1, alpha);
safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1); safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1);
knt = 0; knt = 0;
if (abs(beta) < safmin) { if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */ /* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1. / safmin; rsafmn = 1. / safmin;
L10: L10:
++knt; ++knt;
i__1 = *n - 1; i__1 = *n - 1;
dscal_(&i__1, &rsafmn, &x[1], incx); dscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn; beta *= rsafmn;
*alpha *= rsafmn; *alpha *= rsafmn;
if (abs(beta) < safmin && knt < 20) { if (abs(beta) < safmin && knt < 20) {
goto L10; goto L10;
} }
/* New BETA is at most 1, at least SAFMIN */ /* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1; i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx); xnorm = dnrm2_(&i__1, &x[1], incx);
d__1 = dlapy2_(alpha, &xnorm); d__1 = dlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha); beta = -d_sign(&d__1, alpha);
} }
*tau = (beta - *alpha) / beta; *tau = (beta - *alpha) / beta;
i__1 = *n - 1; i__1 = *n - 1;
d__1 = 1. / (*alpha - beta); d__1 = 1. / (*alpha - beta);
dscal_(&i__1, &d__1, &x[1], incx); dscal_(&i__1, &d__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */ /* If ALPHA is subnormal, it may lose relative accuracy */
i__1 = knt; i__1 = knt;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
beta *= safmin; beta *= safmin;
/* L20: */ /* L20: */
} }
*alpha = beta; *alpha = beta;
} }
return 0; return 0;
@ -236,5 +236,5 @@ L10:
} /* dlarfg_ */ } /* dlarfg_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

282
lib/linalg/dlarft.cpp
View File

@ -1,13 +1,13 @@
/* static/dlarft.f -- translated by f2c (version 20200916). /* static/dlarft.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -185,8 +185,8 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer * /* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
integer *ldt, ftnlen direct_len, ftnlen storev_len) integer *ldt, ftnlen direct_len, ftnlen storev_len)
{ {
/* System generated locals */ /* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
@ -195,13 +195,13 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, j, prevlastv; integer i__, j, prevlastv;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *, extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen); doublereal *, doublereal *, integer *, ftnlen);
integer lastv; integer lastv;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen); ftnlen);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -238,173 +238,173 @@ f"> */
/* Function Body */ /* Function Body */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
prevlastv = *n; prevlastv = *n;
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
prevlastv = max(i__,prevlastv); prevlastv = max(i__,prevlastv);
if (tau[i__] == 0.) { if (tau[i__] == 0.) {
/* H(i) = I */ /* H(i) = I */
i__2 = i__; i__2 = i__;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = 0.; t[j + i__ * t_dim1] = 0.;
} }
} else { } else {
/* general case */ /* general case */
if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) {
/* Skip any trailing zeros. */ /* Skip any trailing zeros. */
i__2 = i__ + 1; i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) { for (lastv = *n; lastv >= i__2; --lastv) {
if (v[lastv + i__ * v_dim1] != 0.) { if (v[lastv + i__ * v_dim1] != 0.) {
goto L219; goto L219;
} }
} }
L219: L219:
i__2 = i__ - 1; i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1];
} }
j = min(lastv,prevlastv); j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */ /* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */
i__2 = j - i__; i__2 = j - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
d__1 = -tau[i__]; d__1 = -tau[i__];
dgemv_((char *)"Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + dgemv_((char *)"Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 +
v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &
c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)9); c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)9);
} else { } else {
/* Skip any trailing zeros. */ /* Skip any trailing zeros. */
i__2 = i__ + 1; i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) { for (lastv = *n; lastv >= i__2; --lastv) {
if (v[i__ + lastv * v_dim1] != 0.) { if (v[i__ + lastv * v_dim1] != 0.) {
goto L235; goto L235;
} }
} }
L235: L235:
i__2 = i__ - 1; i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1];
} }
j = min(lastv,prevlastv); j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */ /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = j - i__; i__3 = j - i__;
d__1 = -tau[i__]; d__1 = -tau[i__];
dgemv_((char *)"No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * dgemv_((char *)"No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) *
v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1],
ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)
12); 12);
} }
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1; i__2 = i__ - 1;
dtrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[ dtrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)
5, (ftnlen)12, (ftnlen)8); 5, (ftnlen)12, (ftnlen)8);
t[i__ + i__ * t_dim1] = tau[i__]; t[i__ + i__ * t_dim1] = tau[i__];
if (i__ > 1) { if (i__ > 1) {
prevlastv = max(prevlastv,lastv); prevlastv = max(prevlastv,lastv);
} else { } else {
prevlastv = lastv; prevlastv = lastv;
} }
} }
} }
} else { } else {
prevlastv = 1; prevlastv = 1;
for (i__ = *k; i__ >= 1; --i__) { for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.) { if (tau[i__] == 0.) {
/* H(i) = I */ /* H(i) = I */
i__1 = *k; i__1 = *k;
for (j = i__; j <= i__1; ++j) { for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.; t[j + i__ * t_dim1] = 0.;
} }
} else { } else {
/* general case */ /* general case */
if (i__ < *k) { if (i__ < *k) {
if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) {
/* Skip any leading zeros. */ /* Skip any leading zeros. */
i__1 = i__ - 1; i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) { for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[lastv + i__ * v_dim1] != 0.) { if (v[lastv + i__ * v_dim1] != 0.) {
goto L280; goto L280;
} }
} }
L280: L280:
i__1 = *k; i__1 = *k;
for (j = i__ + 1; j <= i__1; ++j) { for (j = i__ + 1; j <= i__1; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__
+ j * v_dim1]; + j * v_dim1];
} }
j = max(lastv,prevlastv); j = max(lastv,prevlastv);
/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */ /* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */
i__1 = *n - *k + i__ - j; i__1 = *n - *k + i__ - j;
i__2 = *k - i__; i__2 = *k - i__;
d__1 = -tau[i__]; d__1 = -tau[i__];
dgemv_((char *)"Transpose", &i__1, &i__2, &d__1, &v[j + (i__ dgemv_((char *)"Transpose", &i__1, &i__2, &d__1, &v[j + (i__
+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1], & c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1], &
c__1, (ftnlen)9); c__1, (ftnlen)9);
} else { } else {
/* Skip any leading zeros. */ /* Skip any leading zeros. */
i__1 = i__ - 1; i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) { for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[i__ + lastv * v_dim1] != 0.) { if (v[i__ + lastv * v_dim1] != 0.) {
goto L296; goto L296;
} }
} }
L296: L296:
i__1 = *k; i__1 = *k;
for (j = i__ + 1; j <= i__1; ++j) { for (j = i__ + 1; j <= i__1; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k
+ i__) * v_dim1]; + i__) * v_dim1];
} }
j = max(lastv,prevlastv); j = max(lastv,prevlastv);
/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */ /* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */
i__1 = *k - i__; i__1 = *k - i__;
i__2 = *n - *k + i__ - j; i__2 = *n - *k + i__ - j;
d__1 = -tau[i__]; d__1 = -tau[i__];
dgemv_((char *)"No transpose", &i__1, &i__2, &d__1, &v[i__ + dgemv_((char *)"No transpose", &i__1, &i__2, &d__1, &v[i__ +
1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1, ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1,
(ftnlen)12); (ftnlen)12);
} }
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__; i__1 = *k - i__;
dtrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, &t[i__ dtrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8) t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8)
; ;
if (i__ > 1) { if (i__ > 1) {
prevlastv = min(prevlastv,lastv); prevlastv = min(prevlastv,lastv);
} else { } else {
prevlastv = lastv; prevlastv = lastv;
} }
} }
t[i__ + i__ * t_dim1] = tau[i__]; t[i__ + i__ * t_dim1] = tau[i__];
} }
} }
} }
return 0; return 0;
@ -413,5 +413,5 @@ L296:
} /* dlarft_ */ } /* dlarft_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

140
lib/linalg/dlartg.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlartg.f -- translated by f2c (version 20200916). /* fortran/dlartg.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -115,8 +115,8 @@ f"> */
/* > \ingroup OTHERauxiliary */ /* > \ingroup OTHERauxiliary */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs, /* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs,
doublereal *sn, doublereal *r__) doublereal *sn, doublereal *r__)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -171,81 +171,81 @@ f"> */
/* FIRST = .FALSE. */ /* FIRST = .FALSE. */
/* END IF */ /* END IF */
if (*g == 0.) { if (*g == 0.) {
*cs = 1.; *cs = 1.;
*sn = 0.; *sn = 0.;
*r__ = *f; *r__ = *f;
} else if (*f == 0.) { } else if (*f == 0.) {
*cs = 0.; *cs = 0.;
*sn = 1.; *sn = 1.;
*r__ = *g; *r__ = *g;
} else { } else {
f1 = *f; f1 = *f;
g1 = *g; g1 = *g;
/* Computing MAX */ /* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1); d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2); scale = max(d__1,d__2);
if (scale >= safmx2) { if (scale >= safmx2) {
count = 0; count = 0;
L10: L10:
++count; ++count;
f1 *= safmn2; f1 *= safmn2;
g1 *= safmn2; g1 *= safmn2;
/* Computing MAX */ /* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1); d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2); scale = max(d__1,d__2);
if (scale >= safmx2) { if (scale >= safmx2) {
goto L10; goto L10;
} }
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = f1; d__1 = f1;
/* Computing 2nd power */ /* Computing 2nd power */
d__2 = g1; d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2); *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__; *cs = f1 / *r__;
*sn = g1 / *r__; *sn = g1 / *r__;
i__1 = count; i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmx2; *r__ *= safmx2;
/* L20: */ /* L20: */
} }
} else if (scale <= safmn2) { } else if (scale <= safmn2) {
count = 0; count = 0;
L30: L30:
++count; ++count;
f1 *= safmx2; f1 *= safmx2;
g1 *= safmx2; g1 *= safmx2;
/* Computing MAX */ /* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1); d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2); scale = max(d__1,d__2);
if (scale <= safmn2) { if (scale <= safmn2) {
goto L30; goto L30;
} }
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = f1; d__1 = f1;
/* Computing 2nd power */ /* Computing 2nd power */
d__2 = g1; d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2); *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__; *cs = f1 / *r__;
*sn = g1 / *r__; *sn = g1 / *r__;
i__1 = count; i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmn2; *r__ *= safmn2;
/* L40: */ /* L40: */
} }
} else { } else {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = f1; d__1 = f1;
/* Computing 2nd power */ /* Computing 2nd power */
d__2 = g1; d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2); *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__; *cs = f1 / *r__;
*sn = g1 / *r__; *sn = g1 / *r__;
} }
if (abs(*f) > abs(*g) && *cs < 0.) { if (abs(*f) > abs(*g) && *cs < 0.) {
*cs = -(*cs); *cs = -(*cs);
*sn = -(*sn); *sn = -(*sn);
*r__ = -(*r__); *r__ = -(*r__);
} }
} }
return 0; return 0;
@ -254,5 +254,5 @@ L30:
} /* dlartg_ */ } /* dlartg_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

82
lib/linalg/dlas2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlas2.f -- translated by f2c (version 20200916). /* fortran/dlas2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -123,8 +123,8 @@ extern "C" {
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__, /* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__,
doublereal *ssmin, doublereal *ssmax) doublereal *ssmin, doublereal *ssmax)
{ {
/* System generated locals */ /* System generated locals */
doublereal d__1, d__2; doublereal d__1, d__2;
@ -159,47 +159,47 @@ extern "C" {
fhmn = min(fa,ha); fhmn = min(fa,ha);
fhmx = max(fa,ha); fhmx = max(fa,ha);
if (fhmn == 0.) { if (fhmn == 0.) {
*ssmin = 0.; *ssmin = 0.;
if (fhmx == 0.) { if (fhmx == 0.) {
*ssmax = ga; *ssmax = ga;
} else { } else {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = min(fhmx,ga) / max(fhmx,ga); d__1 = min(fhmx,ga) / max(fhmx,ga);
*ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.); *ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.);
} }
} else { } else {
if (ga < fhmx) { if (ga < fhmx) {
as = fhmn / fhmx + 1.; as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx; at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = ga / fhmx; d__1 = ga / fhmx;
au = d__1 * d__1; au = d__1 * d__1;
c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au)); c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au));
*ssmin = fhmn * c__; *ssmin = fhmn * c__;
*ssmax = fhmx / c__; *ssmax = fhmx / c__;
} else { } else {
au = fhmx / ga; au = fhmx / ga;
if (au == 0.) { if (au == 0.) {
/* Avoid possible harmful underflow if exponent range */ /* Avoid possible harmful underflow if exponent range */
/* asymmetric (true SSMIN may not underflow even if */ /* asymmetric (true SSMIN may not underflow even if */
/* AU underflows) */ /* AU underflows) */
*ssmin = fhmn * fhmx / ga; *ssmin = fhmn * fhmx / ga;
*ssmax = ga; *ssmax = ga;
} else { } else {
as = fhmn / fhmx + 1.; as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx; at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = as * au; d__1 = as * au;
/* Computing 2nd power */ /* Computing 2nd power */
d__2 = at * au; d__2 = at * au;
c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.)); c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.));
*ssmin = fhmn * c__ * au; *ssmin = fhmn * c__ * au;
*ssmin += *ssmin; *ssmin += *ssmin;
*ssmax = ga / (c__ + c__); *ssmax = ga / (c__ + c__);
} }
} }
} }
return 0; return 0;
@ -208,5 +208,5 @@ extern "C" {
} /* dlas2_ */ } /* dlas2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

256
lib/linalg/dlascl.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlascl.f -- translated by f2c (version 20200916). /* fortran/dlascl.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -159,9 +159,9 @@ f"> */
/* > \ingroup OTHERauxiliary */ /* > \ingroup OTHERauxiliary */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku, /* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku,
doublereal *cfrom, doublereal *cto, integer *m, integer *n, doublereal *cfrom, doublereal *cto, integer *m, integer *n,
doublereal *a, integer *lda, integer *info, ftnlen type_len) doublereal *a, integer *lda, integer *info, ftnlen type_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
@ -215,63 +215,63 @@ f"> */
*info = 0; *info = 0;
if (lsame_(type__, (char *)"G", (ftnlen)1, (ftnlen)1)) { if (lsame_(type__, (char *)"G", (ftnlen)1, (ftnlen)1)) {
itype = 0; itype = 0;
} else if (lsame_(type__, (char *)"L", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(type__, (char *)"L", (ftnlen)1, (ftnlen)1)) {
itype = 1; itype = 1;
} else if (lsame_(type__, (char *)"U", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(type__, (char *)"U", (ftnlen)1, (ftnlen)1)) {
itype = 2; itype = 2;
} else if (lsame_(type__, (char *)"H", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(type__, (char *)"H", (ftnlen)1, (ftnlen)1)) {
itype = 3; itype = 3;
} else if (lsame_(type__, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(type__, (char *)"B", (ftnlen)1, (ftnlen)1)) {
itype = 4; itype = 4;
} else if (lsame_(type__, (char *)"Q", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(type__, (char *)"Q", (ftnlen)1, (ftnlen)1)) {
itype = 5; itype = 5;
} else if (lsame_(type__, (char *)"Z", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(type__, (char *)"Z", (ftnlen)1, (ftnlen)1)) {
itype = 6; itype = 6;
} else { } else {
itype = -1; itype = -1;
} }
if (itype == -1) { if (itype == -1) {
*info = -1; *info = -1;
} else if (*cfrom == 0. || disnan_(cfrom)) { } else if (*cfrom == 0. || disnan_(cfrom)) {
*info = -4; *info = -4;
} else if (disnan_(cto)) { } else if (disnan_(cto)) {
*info = -5; *info = -5;
} else if (*m < 0) { } else if (*m < 0) {
*info = -6; *info = -6;
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
*info = -7; *info = -7;
} else if (itype <= 3 && *lda < max(1,*m)) { } else if (itype <= 3 && *lda < max(1,*m)) {
*info = -9; *info = -9;
} else if (itype >= 4) { } else if (itype >= 4) {
/* Computing MAX */ /* Computing MAX */
i__1 = *m - 1; i__1 = *m - 1;
if (*kl < 0 || *kl > max(i__1,0)) { if (*kl < 0 || *kl > max(i__1,0)) {
*info = -2; *info = -2;
} else /* if(complicated condition) */ { } else /* if(complicated condition) */ {
/* Computing MAX */ /* Computing MAX */
i__1 = *n - 1; i__1 = *n - 1;
if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
*kl != *ku) { *kl != *ku) {
*info = -3; *info = -3;
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
*info = -9; *info = -9;
} }
} }
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASCL", &i__1, (ftnlen)6); xerbla_((char *)"DLASCL", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0 || *m == 0) { if (*n == 0 || *m == 0) {
return 0; return 0;
} }
/* Get machine parameters */ /* Get machine parameters */
@ -287,154 +287,154 @@ L10:
if (cfrom1 == cfromc) { if (cfrom1 == cfromc) {
/* CFROMC is an inf. Multiply by a correctly signed zero for */ /* CFROMC is an inf. Multiply by a correctly signed zero for */
/* finite CTOC, or a NaN if CTOC is infinite. */ /* finite CTOC, or a NaN if CTOC is infinite. */
mul = ctoc / cfromc; mul = ctoc / cfromc;
done = TRUE_; done = TRUE_;
cto1 = ctoc; cto1 = ctoc;
} else { } else {
cto1 = ctoc / bignum; cto1 = ctoc / bignum;
if (cto1 == ctoc) { if (cto1 == ctoc) {
/* CTOC is either 0 or an inf. In both cases, CTOC itself */ /* CTOC is either 0 or an inf. In both cases, CTOC itself */
/* serves as the correct multiplication factor. */ /* serves as the correct multiplication factor. */
mul = ctoc; mul = ctoc;
done = TRUE_; done = TRUE_;
cfromc = 1.; cfromc = 1.;
} else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
mul = smlnum; mul = smlnum;
done = FALSE_; done = FALSE_;
cfromc = cfrom1; cfromc = cfrom1;
} else if (abs(cto1) > abs(cfromc)) { } else if (abs(cto1) > abs(cfromc)) {
mul = bignum; mul = bignum;
done = FALSE_; done = FALSE_;
ctoc = cto1; ctoc = cto1;
} else { } else {
mul = ctoc / cfromc; mul = ctoc / cfromc;
done = TRUE_; done = TRUE_;
if (mul == 1.) { if (mul == 1.) {
return 0; return 0;
} }
} }
} }
if (itype == 0) { if (itype == 0) {
/* Full matrix */ /* Full matrix */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul; a[i__ + j * a_dim1] *= mul;
/* L20: */ /* L20: */
} }
/* L30: */ /* L30: */
} }
} else if (itype == 1) { } else if (itype == 1) {
/* Lower triangular matrix */ /* Lower triangular matrix */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) { for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul; a[i__ + j * a_dim1] *= mul;
/* L40: */ /* L40: */
} }
/* L50: */ /* L50: */
} }
} else if (itype == 2) { } else if (itype == 2) {
/* Upper triangular matrix */ /* Upper triangular matrix */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m); i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul; a[i__ + j * a_dim1] *= mul;
/* L60: */ /* L60: */
} }
/* L70: */ /* L70: */
} }
} else if (itype == 3) { } else if (itype == 3) {
/* Upper Hessenberg matrix */ /* Upper Hessenberg matrix */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
/* Computing MIN */ /* Computing MIN */
i__3 = j + 1; i__3 = j + 1;
i__2 = min(i__3,*m); i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul; a[i__ + j * a_dim1] *= mul;
/* L80: */ /* L80: */
} }
/* L90: */ /* L90: */
} }
} else if (itype == 4) { } else if (itype == 4) {
/* Lower half of a symmetric band matrix */ /* Lower half of a symmetric band matrix */
k3 = *kl + 1; k3 = *kl + 1;
k4 = *n + 1; k4 = *n + 1;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
/* Computing MIN */ /* Computing MIN */
i__3 = k3, i__4 = k4 - j; i__3 = k3, i__4 = k4 - j;
i__2 = min(i__3,i__4); i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul; a[i__ + j * a_dim1] *= mul;
/* L100: */ /* L100: */
} }
/* L110: */ /* L110: */
} }
} else if (itype == 5) { } else if (itype == 5) {
/* Upper half of a symmetric band matrix */ /* Upper half of a symmetric band matrix */
k1 = *ku + 2; k1 = *ku + 2;
k3 = *ku + 1; k3 = *ku + 1;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
/* Computing MAX */ /* Computing MAX */
i__2 = k1 - j; i__2 = k1 - j;
i__3 = k3; i__3 = k3;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) { for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
a[i__ + j * a_dim1] *= mul; a[i__ + j * a_dim1] *= mul;
/* L120: */ /* L120: */
} }
/* L130: */ /* L130: */
} }
} else if (itype == 6) { } else if (itype == 6) {
/* Band matrix */ /* Band matrix */
k1 = *kl + *ku + 2; k1 = *kl + *ku + 2;
k2 = *kl + 1; k2 = *kl + 1;
k3 = (*kl << 1) + *ku + 1; k3 = (*kl << 1) + *ku + 1;
k4 = *kl + *ku + 1 + *m; k4 = *kl + *ku + 1 + *m;
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
/* Computing MAX */ /* Computing MAX */
i__3 = k1 - j; i__3 = k1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = k3, i__5 = k4 - j; i__4 = k3, i__5 = k4 - j;
i__2 = min(i__4,i__5); i__2 = min(i__4,i__5);
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul; a[i__ + j * a_dim1] *= mul;
/* L140: */ /* L140: */
} }
/* L150: */ /* L150: */
} }
} }
if (! done) { if (! done) {
goto L10; goto L10;
} }
return 0; return 0;
@ -444,5 +444,5 @@ L10:
} /* dlascl_ */ } /* dlascl_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

1364
lib/linalg/dlasd4.cpp
View File

File diff suppressed because it is too large Load Diff

102
lib/linalg/dlasd5.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasd5.f -- translated by f2c (version 20200916). /* fortran/dlasd5.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -133,9 +133,9 @@ f"> */
/* > at Berkeley, USA */ /* > at Berkeley, USA */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__, /* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__,
doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal * doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal *
work) work)
{ {
/* System generated locals */ /* System generated locals */
doublereal d__1; doublereal d__1;
@ -176,51 +176,51 @@ f"> */
del = d__[2] - d__[1]; del = d__[2] - d__[1];
delsq = del * (d__[2] + d__[1]); delsq = del * (d__[2] + d__[1]);
if (*i__ == 1) { if (*i__ == 1) {
w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] * w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] *
z__[1] / (d__[1] * 3. + d__[2])) / del + 1.; z__[1] / (d__[1] * 3. + d__[2])) / del + 1.;
if (w > 0.) { if (w > 0.) {
b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[1] * z__[1] * delsq; c__ = *rho * z__[1] * z__[1] * delsq;
/* B > ZERO, always */ /* B > ZERO, always */
/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */ /* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */
tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
/* The following TAU is DSIGMA - D( 1 ) */ /* The following TAU is DSIGMA - D( 1 ) */
tau /= d__[1] + sqrt(d__[1] * d__[1] + tau); tau /= d__[1] + sqrt(d__[1] * d__[1] + tau);
*dsigma = d__[1] + tau; *dsigma = d__[1] + tau;
delta[1] = -tau; delta[1] = -tau;
delta[2] = del - tau; delta[2] = del - tau;
work[1] = d__[1] * 2. + tau; work[1] = d__[1] * 2. + tau;
work[2] = d__[1] + tau + d__[2]; work[2] = d__[1] + tau + d__[2];
/* DELTA( 1 ) = -Z( 1 ) / TAU */ /* DELTA( 1 ) = -Z( 1 ) / TAU */
/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */ /* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */
} else { } else {
b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * delsq; c__ = *rho * z__[2] * z__[2] * delsq;
/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ /* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
if (b > 0.) { if (b > 0.) {
tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.));
} else { } else {
tau = (b - sqrt(b * b + c__ * 4.)) / 2.; tau = (b - sqrt(b * b + c__ * 4.)) / 2.;
} }
/* The following TAU is DSIGMA - D( 2 ) */ /* The following TAU is DSIGMA - D( 2 ) */
tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1))); tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1)));
*dsigma = d__[2] + tau; *dsigma = d__[2] + tau;
delta[1] = -(del + tau); delta[1] = -(del + tau);
delta[2] = -tau; delta[2] = -tau;
work[1] = d__[1] + tau + d__[2]; work[1] = d__[1] + tau + d__[2];
work[2] = d__[2] * 2. + tau; work[2] = d__[2] * 2. + tau;
/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ /* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
/* DELTA( 2 ) = -Z( 2 ) / TAU */ /* DELTA( 2 ) = -Z( 2 ) / TAU */
} }
/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ /* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
/* DELTA( 1 ) = DELTA( 1 ) / TEMP */ /* DELTA( 1 ) = DELTA( 1 ) / TEMP */
/* DELTA( 2 ) = DELTA( 2 ) / TEMP */ /* DELTA( 2 ) = DELTA( 2 ) / TEMP */
@ -228,25 +228,25 @@ f"> */
/* Now I=2 */ /* Now I=2 */
b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * delsq; c__ = *rho * z__[2] * z__[2] * delsq;
/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ /* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
if (b > 0.) { if (b > 0.) {
tau = (b + sqrt(b * b + c__ * 4.)) / 2.; tau = (b + sqrt(b * b + c__ * 4.)) / 2.;
} else { } else {
tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.));
} }
/* The following TAU is DSIGMA - D( 2 ) */ /* The following TAU is DSIGMA - D( 2 ) */
tau /= d__[2] + sqrt(d__[2] * d__[2] + tau); tau /= d__[2] + sqrt(d__[2] * d__[2] + tau);
*dsigma = d__[2] + tau; *dsigma = d__[2] + tau;
delta[1] = -(del + tau); delta[1] = -(del + tau);
delta[2] = -tau; delta[2] = -tau;
work[1] = d__[1] + tau + d__[2]; work[1] = d__[1] + tau + d__[2];
work[2] = d__[2] * 2. + tau; work[2] = d__[2] * 2. + tau;
/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ /* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
/* DELTA( 2 ) = -Z( 2 ) / TAU */ /* DELTA( 2 ) = -Z( 2 ) / TAU */
/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ /* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
@ -260,5 +260,5 @@ f"> */
} /* dlasd5_ */ } /* dlasd5_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

106
lib/linalg/dlasd6.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasd6.f -- translated by f2c (version 20200916). /* fortran/dlasd6.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -334,34 +334,34 @@ f"> */
/* > California at Berkeley, USA */ /* > California at Berkeley, USA */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr, /* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr,
integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl, integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl,
doublereal *alpha, doublereal *beta, integer *idxq, integer *perm, doublereal *alpha, doublereal *beta, integer *idxq, integer *perm,
integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
integer *ldgnum, doublereal *poles, doublereal *difl, doublereal * integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *
difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s, difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s,
doublereal *work, integer *iwork, integer *info) doublereal *work, integer *iwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, i__1; poles_dim1, poles_offset, i__1;
doublereal d__1, d__2; doublereal d__1, d__2;
/* Local variables */ /* Local variables */
integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw; integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlasd7_(integer *, integer *, integer *, doublereal *, integer *), dlasd7_(integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *), dlasd8_( *, integer *, doublereal *, doublereal *, integer *), dlasd8_(
integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *, doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlamrg_(integer *, integer *, integer *, integer *, ftnlen), dlamrg_(integer *, integer *,
doublereal *, integer *, integer *, integer *); doublereal *, integer *, integer *, integer *);
integer isigma; integer isigma;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
doublereal orgnrm; doublereal orgnrm;
@ -417,22 +417,22 @@ f"> */
m = n + *sqre; m = n + *sqre;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*nl < 1) { } else if (*nl < 1) {
*info = -2; *info = -2;
} else if (*nr < 1) { } else if (*nr < 1) {
*info = -3; *info = -3;
} else if (*sqre < 0 || *sqre > 1) { } else if (*sqre < 0 || *sqre > 1) {
*info = -4; *info = -4;
} else if (*ldgcol < n) { } else if (*ldgcol < n) {
*info = -14; *info = -14;
} else if (*ldgnum < n) { } else if (*ldgnum < n) {
*info = -16; *info = -16;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASD6", &i__1, (ftnlen)6); xerbla_((char *)"DLASD6", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* The following values are for bookkeeping purposes only. They are */ /* The following values are for bookkeeping purposes only. They are */
@ -456,46 +456,46 @@ f"> */
d__[*nl + 1] = 0.; d__[*nl + 1] = 0.;
i__1 = n; i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) > orgnrm) { if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
orgnrm = (d__1 = d__[i__], abs(d__1)); orgnrm = (d__1 = d__[i__], abs(d__1));
} }
/* L10: */ /* L10: */
} }
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info, ( dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info, (
ftnlen)1); ftnlen)1);
*alpha /= orgnrm; *alpha /= orgnrm;
*beta /= orgnrm; *beta /= orgnrm;
/* Sort and Deflate singular values. */ /* Sort and Deflate singular values. */
dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], & dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], &
work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], & work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], &
iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[ iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[
givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s,
info); info);
/* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */ /* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */
dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1],
ldgnum, &work[isigma], &work[iw], info); ldgnum, &work[isigma], &work[iw], info);
/* Report the possible convergence failure. */ /* Report the possible convergence failure. */
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
/* Save the poles if ICOMPQ = 1. */ /* Save the poles if ICOMPQ = 1. */
if (*icompq == 1) { if (*icompq == 1) {
dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1);
dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1);
} }
/* Unscale. */ /* Unscale. */
dlascl_((char *)"G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info, ( dlascl_((char *)"G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info, (
ftnlen)1); ftnlen)1);
/* Prepare the IDXQ sorting permutation. */ /* Prepare the IDXQ sorting permutation. */
@ -510,5 +510,5 @@ f"> */
} /* dlasd6_ */ } /* dlasd6_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

258
lib/linalg/dlasd7.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasd7.f -- translated by f2c (version 20200916). /* fortran/dlasd7.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -19,7 +19,7 @@ extern "C" {
static integer c__1 = 1; static integer c__1 = 1;
/* > \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries /* > \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries
to deflate the size of the problem. Used by sbdsdc. */ to deflate the size of the problem. Used by sbdsdc. */
/* =========== DOCUMENTATION =========== */ /* =========== DOCUMENTATION =========== */
@ -298,13 +298,13 @@ f"> */
/* > California at Berkeley, USA */ /* > California at Berkeley, USA */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr, /* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *k, doublereal *d__, doublereal *z__, integer *sqre, integer *k, doublereal *d__, doublereal *z__,
doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl, doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl,
doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal * doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *
dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm,
integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
integer *ldgnum, doublereal *c__, doublereal *s, integer *info) integer *ldgnum, doublereal *c__, doublereal *s, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1;
@ -316,17 +316,17 @@ f"> */
integer jp; integer jp;
doublereal eps, tau, tol; doublereal eps, tau, tol;
integer nlp1, nlp2, idxi, idxj; integer nlp1, nlp2, idxi, idxj;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *); doublereal *, integer *, doublereal *, doublereal *);
integer idxjp; integer idxjp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
integer jprev; integer jprev;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen); ftnlen);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *, integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen); ftnlen);
doublereal hlftol; doublereal hlftol;
@ -382,28 +382,28 @@ f"> */
m = n + *sqre; m = n + *sqre;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*nl < 1) { } else if (*nl < 1) {
*info = -2; *info = -2;
} else if (*nr < 1) { } else if (*nr < 1) {
*info = -3; *info = -3;
} else if (*sqre < 0 || *sqre > 1) { } else if (*sqre < 0 || *sqre > 1) {
*info = -4; *info = -4;
} else if (*ldgcol < n) { } else if (*ldgcol < n) {
*info = -22; *info = -22;
} else if (*ldgnum < n) { } else if (*ldgnum < n) {
*info = -24; *info = -24;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASD7", &i__1, (ftnlen)6); xerbla_((char *)"DLASD7", &i__1, (ftnlen)6);
return 0; return 0;
} }
nlp1 = *nl + 1; nlp1 = *nl + 1;
nlp2 = *nl + 2; nlp2 = *nl + 2;
if (*icompq == 1) { if (*icompq == 1) {
*givptr = 0; *givptr = 0;
} }
/* Generate the first part of the vector Z and move the singular */ /* Generate the first part of the vector Z and move the singular */
@ -413,11 +413,11 @@ f"> */
vl[nlp1] = 0.; vl[nlp1] = 0.;
tau = vf[nlp1]; tau = vf[nlp1];
for (i__ = *nl; i__ >= 1; --i__) { for (i__ = *nl; i__ >= 1; --i__) {
z__[i__ + 1] = *alpha * vl[i__]; z__[i__ + 1] = *alpha * vl[i__];
vl[i__] = 0.; vl[i__] = 0.;
vf[i__ + 1] = vf[i__]; vf[i__ + 1] = vf[i__];
d__[i__ + 1] = d__[i__]; d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1; idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */ /* L10: */
} }
vf[1] = tau; vf[1] = tau;
@ -426,8 +426,8 @@ f"> */
i__1 = m; i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) { for (i__ = nlp2; i__ <= i__1; ++i__) {
z__[i__] = *beta * vf[i__]; z__[i__] = *beta * vf[i__];
vf[i__] = 0.; vf[i__] = 0.;
/* L20: */ /* L20: */
} }
@ -435,7 +435,7 @@ f"> */
i__1 = n; i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) { for (i__ = nlp2; i__ <= i__1; ++i__) {
idxq[i__] += nlp1; idxq[i__] += nlp1;
/* L30: */ /* L30: */
} }
@ -443,10 +443,10 @@ f"> */
i__1 = n; i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
dsigma[i__] = d__[idxq[i__]]; dsigma[i__] = d__[idxq[i__]];
zw[i__] = z__[idxq[i__]]; zw[i__] = z__[idxq[i__]];
vfw[i__] = vf[idxq[i__]]; vfw[i__] = vf[idxq[i__]];
vlw[i__] = vl[idxq[i__]]; vlw[i__] = vl[idxq[i__]];
/* L40: */ /* L40: */
} }
@ -454,11 +454,11 @@ f"> */
i__1 = n; i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
idxi = idx[i__] + 1; idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi]; d__[i__] = dsigma[idxi];
z__[i__] = zw[idxi]; z__[i__] = zw[idxi];
vf[i__] = vfw[idxi]; vf[i__] = vfw[idxi];
vl[i__] = vlw[idxi]; vl[i__] = vlw[idxi];
/* L50: */ /* L50: */
} }
@ -495,19 +495,19 @@ f"> */
k2 = n + 1; k2 = n + 1;
i__1 = n; i__1 = n;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
if ((d__1 = z__[j], abs(d__1)) <= tol) { if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */ /* Deflate due to small z component. */
--k2; --k2;
idxp[k2] = j; idxp[k2] = j;
if (j == n) { if (j == n) {
goto L100; goto L100;
} }
} else { } else {
jprev = j; jprev = j;
goto L70; goto L70;
} }
/* L60: */ /* L60: */
} }
L70: L70:
@ -515,63 +515,63 @@ L70:
L80: L80:
++j; ++j;
if (j > n) { if (j > n) {
goto L90; goto L90;
} }
if ((d__1 = z__[j], abs(d__1)) <= tol) { if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */ /* Deflate due to small z component. */
--k2; --k2;
idxp[k2] = j; idxp[k2] = j;
} else { } else {
/* Check if singular values are close enough to allow deflation. */ /* Check if singular values are close enough to allow deflation. */
if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
/* Deflation is possible. */ /* Deflation is possible. */
*s = z__[jprev]; *s = z__[jprev];
*c__ = z__[j]; *c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */ /* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */ /* destructive underflow. */
tau = dlapy2_(c__, s); tau = dlapy2_(c__, s);
z__[j] = tau; z__[j] = tau;
z__[jprev] = 0.; z__[jprev] = 0.;
*c__ /= tau; *c__ /= tau;
*s = -(*s) / tau; *s = -(*s) / tau;
/* Record the appropriate Givens rotation */ /* Record the appropriate Givens rotation */
if (*icompq == 1) { if (*icompq == 1) {
++(*givptr); ++(*givptr);
idxjp = idxq[idx[jprev] + 1]; idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1]; idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1) { if (idxjp <= nlp1) {
--idxjp; --idxjp;
} }
if (idxj <= nlp1) { if (idxj <= nlp1) {
--idxj; --idxj;
} }
givcol[*givptr + (givcol_dim1 << 1)] = idxjp; givcol[*givptr + (givcol_dim1 << 1)] = idxjp;
givcol[*givptr + givcol_dim1] = idxj; givcol[*givptr + givcol_dim1] = idxj;
givnum[*givptr + (givnum_dim1 << 1)] = *c__; givnum[*givptr + (givnum_dim1 << 1)] = *c__;
givnum[*givptr + givnum_dim1] = *s; givnum[*givptr + givnum_dim1] = *s;
} }
drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s);
drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s); drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s);
--k2; --k2;
idxp[k2] = jprev; idxp[k2] = jprev;
jprev = j; jprev = j;
} else { } else {
++(*k); ++(*k);
zw[*k] = z__[jprev]; zw[*k] = z__[jprev];
dsigma[*k] = d__[jprev]; dsigma[*k] = d__[jprev];
idxp[*k] = jprev; idxp[*k] = jprev;
jprev = j; jprev = j;
} }
} }
goto L80; goto L80;
L90: L90:
@ -591,22 +591,22 @@ L100:
i__1 = n; i__1 = n;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
jp = idxp[j]; jp = idxp[j];
dsigma[j] = d__[jp]; dsigma[j] = d__[jp];
vfw[j] = vf[jp]; vfw[j] = vf[jp];
vlw[j] = vl[jp]; vlw[j] = vl[jp];
/* L110: */ /* L110: */
} }
if (*icompq == 1) { if (*icompq == 1) {
i__1 = n; i__1 = n;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
jp = idxp[j]; jp = idxp[j];
perm[j] = idxq[idx[jp] + 1]; perm[j] = idxq[idx[jp] + 1];
if (perm[j] <= nlp1) { if (perm[j] <= nlp1) {
--perm[j]; --perm[j];
} }
/* L120: */ /* L120: */
} }
} }
/* The deflated singular values go back into the last N - K slots of */ /* The deflated singular values go back into the last N - K slots of */
@ -621,26 +621,26 @@ L100:
dsigma[1] = 0.; dsigma[1] = 0.;
hlftol = tol / 2.; hlftol = tol / 2.;
if (abs(dsigma[2]) <= hlftol) { if (abs(dsigma[2]) <= hlftol) {
dsigma[2] = hlftol; dsigma[2] = hlftol;
} }
if (m > n) { if (m > n) {
z__[1] = dlapy2_(&z1, &z__[m]); z__[1] = dlapy2_(&z1, &z__[m]);
if (z__[1] <= tol) { if (z__[1] <= tol) {
*c__ = 1.; *c__ = 1.;
*s = 0.; *s = 0.;
z__[1] = tol; z__[1] = tol;
} else { } else {
*c__ = z1 / z__[1]; *c__ = z1 / z__[1];
*s = -z__[m] / z__[1]; *s = -z__[m] / z__[1];
} }
drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s);
drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s);
} else { } else {
if (abs(z1) <= tol) { if (abs(z1) <= tol) {
z__[1] = tol; z__[1] = tol;
} else { } else {
z__[1] = z1; z__[1] = z1;
} }
} }
/* Restore Z, VF, and VL. */ /* Restore Z, VF, and VL. */
@ -659,5 +659,5 @@ L100:
} /* dlasd7_ */ } /* dlasd7_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

168
lib/linalg/dlasd8.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasd8.f -- translated by f2c (version 20200916). /* fortran/dlasd8.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -188,10 +188,10 @@ f"> */
/* > California at Berkeley, USA */ /* > California at Berkeley, USA */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__, /* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl, doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal * doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
work, integer *info) work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer difr_dim1, difr_offset, i__1, i__2; integer difr_dim1, difr_offset, i__1, i__2;
@ -204,22 +204,22 @@ f"> */
integer i__, j; integer i__, j;
doublereal dj, rho; doublereal dj, rho;
integer iwk1, iwk2, iwk3; integer iwk1, iwk2, iwk3;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *); integer *);
doublereal temp; doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *); extern doublereal dnrm2_(integer *, doublereal *, integer *);
integer iwk2i, iwk3i; integer iwk2i, iwk3i;
doublereal diflj, difrj, dsigj; doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *); extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *, doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlaset_(char *, integer *, integer integer *, integer *, ftnlen), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *, ftnlen), *, doublereal *, doublereal *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen); xerbla_(char *, integer *, ftnlen);
doublereal dsigjp; doublereal dsigjp;
@ -264,28 +264,28 @@ f"> */
*info = 0; *info = 0;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*k < 1) { } else if (*k < 1) {
*info = -2; *info = -2;
} else if (*lddifr < *k) { } else if (*lddifr < *k) {
*info = -9; *info = -9;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASD8", &i__1, (ftnlen)6); xerbla_((char *)"DLASD8", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*k == 1) { if (*k == 1) {
d__[1] = abs(z__[1]); d__[1] = abs(z__[1]);
difl[1] = d__[1]; difl[1] = d__[1];
if (*icompq == 1) { if (*icompq == 1) {
difl[2] = 1.; difl[2] = 1.;
difr[(difr_dim1 << 1) + 1] = 1.; difr[(difr_dim1 << 1) + 1] = 1.;
} }
return 0; return 0;
} }
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ /* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
@ -307,7 +307,7 @@ f"> */
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L10: */ /* L10: */
} }
@ -323,7 +323,7 @@ f"> */
rho = dnrm2_(k, &z__[1], &c__1); rho = dnrm2_(k, &z__[1], &c__1);
dlascl_((char *)"G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info, ( dlascl_((char *)"G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info, (
ftnlen)1); ftnlen)1);
rho *= rho; rho *= rho;
/* Initialize WORK(IWK3). */ /* Initialize WORK(IWK3). */
@ -335,31 +335,31 @@ f"> */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[ dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
iwk2], info); iwk2], info);
/* If the root finder fails, report the convergence failure. */ /* If the root finder fails, report the convergence failure. */
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j]; work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
difl[j] = -work[j]; difl[j] = -work[j];
difr[j + difr_dim1] = -work[j + 1]; difr[j + difr_dim1] = -work[j + 1];
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]); j]);
/* L20: */ /* L20: */
} }
i__2 = *k; i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]); j]);
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
@ -367,8 +367,8 @@ f"> */
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1))); d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1)));
z__[i__] = d_sign(&d__2, &z__[i__]); z__[i__] = d_sign(&d__2, &z__[i__]);
/* L50: */ /* L50: */
} }
@ -376,32 +376,32 @@ f"> */
i__1 = *k; i__1 = *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
diflj = difl[j]; diflj = difl[j];
dj = d__[j]; dj = d__[j];
dsigj = -dsigma[j]; dsigj = -dsigma[j];
if (j < *k) { if (j < *k) {
difrj = -difr[j + difr_dim1]; difrj = -difr[j + difr_dim1];
dsigjp = -dsigma[j + 1]; dsigjp = -dsigma[j + 1];
} }
work[j] = -z__[j] / diflj / (dsigma[j] + dj); work[j] = -z__[j] / diflj / (dsigma[j] + dj);
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / ( work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (
dsigma[i__] + dj); dsigma[i__] + dj);
/* L60: */ /* L60: */
} }
i__2 = *k; i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) / work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) /
(dsigma[i__] + dj); (dsigma[i__] + dj);
/* L70: */ /* L70: */
} }
temp = dnrm2_(k, &work[1], &c__1); temp = dnrm2_(k, &work[1], &c__1);
work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
if (*icompq == 1) { if (*icompq == 1) {
difr[j + (difr_dim1 << 1)] = temp; difr[j + (difr_dim1 << 1)] = temp;
} }
/* L80: */ /* L80: */
} }
@ -415,5 +415,5 @@ f"> */
} /* dlasd8_ */ } /* dlasd8_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

364
lib/linalg/dlasda.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasda.f -- translated by f2c (version 20200916). /* fortran/dlasda.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -296,47 +296,47 @@ f"> */
/* > California at Berkeley, USA */ /* > California at Berkeley, USA */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n, /* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n,
integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer
*ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr, *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr,
doublereal *z__, doublereal *poles, integer *givptr, integer *givcol, doublereal *z__, doublereal *poles, integer *givptr, integer *givcol,
integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__, integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__,
doublereal *s, doublereal *work, integer *iwork, integer *info) doublereal *s, doublereal *work, integer *iwork, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
z_dim1, z_offset, i__1, i__2; z_dim1, z_offset, i__1, i__2;
/* Builtin functions */ /* Builtin functions */
integer pow_ii(integer *, integer *); integer pow_ii(integer *, integer *);
/* Local variables */ /* Local variables */
integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf, integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf,
vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1; vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1;
doublereal beta; doublereal beta;
integer idxq, nlvl; integer idxq, nlvl;
doublereal alpha; doublereal alpha;
integer inode, ndiml, ndimr, idxqi, itemp; integer inode, ndiml, ndimr, idxqi, itemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
integer sqrei; integer sqrei;
extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *, extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *); doublereal *, integer *, integer *);
integer nwork1, nwork2; integer nwork1, nwork2;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *, *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, ftnlen), dlasdt_(integer *, integer *, doublereal *, integer *, ftnlen), dlasdt_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlaset_( integer *, integer *, integer *, integer *, integer *), dlaset_(
char *, integer *, integer *, doublereal *, doublereal *, char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen), xerbla_(char *, integer *, doublereal *, integer *, ftnlen), xerbla_(char *, integer *,
ftnlen); ftnlen);
integer smlszp; integer smlszp;
@ -402,22 +402,22 @@ f"> */
*info = 0; *info = 0;
if (*icompq < 0 || *icompq > 1) { if (*icompq < 0 || *icompq > 1) {
*info = -1; *info = -1;
} else if (*smlsiz < 3) { } else if (*smlsiz < 3) {
*info = -2; *info = -2;
} else if (*n < 0) { } else if (*n < 0) {
*info = -3; *info = -3;
} else if (*sqre < 0 || *sqre > 1) { } else if (*sqre < 0 || *sqre > 1) {
*info = -4; *info = -4;
} else if (*ldu < *n + *sqre) { } else if (*ldu < *n + *sqre) {
*info = -8; *info = -8;
} else if (*ldgcol < *n) { } else if (*ldgcol < *n) {
*info = -17; *info = -17;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASDA", &i__1, (ftnlen)6); xerbla_((char *)"DLASDA", &i__1, (ftnlen)6);
return 0; return 0;
} }
m = *n + *sqre; m = *n + *sqre;
@ -425,16 +425,16 @@ f"> */
/* If the input matrix is too small, call DLASDQ to find the SVD. */ /* If the input matrix is too small, call DLASDQ to find the SVD. */
if (*n <= *smlsiz) { if (*n <= *smlsiz) {
if (*icompq == 0) { if (*icompq == 0) {
dlasdq_((char *)"U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ dlasdq_((char *)"U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, & vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, &
work[1], info, (ftnlen)1); work[1], info, (ftnlen)1);
} else { } else {
dlasdq_((char *)"U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset] dlasdq_((char *)"U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], , ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1],
info, (ftnlen)1); info, (ftnlen)1);
} }
return 0; return 0;
} }
/* Book-keeping and set up the computation tree. */ /* Book-keeping and set up the computation tree. */
@ -454,8 +454,8 @@ f"> */
nwork1 = vl + m; nwork1 = vl + m;
nwork2 = nwork1 + smlszp * smlszp; nwork2 = nwork1 + smlszp * smlszp;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz); smlsiz);
/* for the nodes on bottom level of the tree, solve */ /* for the nodes on bottom level of the tree, solve */
/* their subproblems by DLASDQ. */ /* their subproblems by DLASDQ. */
@ -470,84 +470,84 @@ f"> */
/* NLF: starting row of the left subproblem */ /* NLF: starting row of the left subproblem */
/* NRF: starting row of the right subproblem */ /* NRF: starting row of the right subproblem */
i1 = i__ - 1; i1 = i__ - 1;
ic = iwork[inode + i1]; ic = iwork[inode + i1];
nl = iwork[ndiml + i1]; nl = iwork[ndiml + i1];
nlp1 = nl + 1; nlp1 = nl + 1;
nr = iwork[ndimr + i1]; nr = iwork[ndimr + i1];
nlf = ic - nl; nlf = ic - nl;
nrf = ic + 1; nrf = ic + 1;
idxqi = idxq + nlf - 2; idxqi = idxq + nlf - 2;
vfi = vf + nlf - 1; vfi = vf + nlf - 1;
vli = vl + nlf - 1; vli = vl + nlf - 1;
sqrei = 1; sqrei = 1;
if (*icompq == 0) { if (*icompq == 0) {
dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp, dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp,
(ftnlen)1); (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], & dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2], work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
&nl, &work[nwork2], info, (ftnlen)1); &nl, &work[nwork2], info, (ftnlen)1);
itemp = nwork1 + nl * smlszp; itemp = nwork1 + nl * smlszp;
dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
} else { } else {
dlaset_((char *)"A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu, ( dlaset_((char *)"A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu, (
ftnlen)1); ftnlen)1);
dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1],
ldu, (ftnlen)1); ldu, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], & dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf + vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf +
u_dim1], ldu, &work[nwork1], info, (ftnlen)1); u_dim1], ldu, &work[nwork1], info, (ftnlen)1);
dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1) dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1)
; ;
} }
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
i__2 = nl; i__2 = nl;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j; iwork[idxqi + j] = j;
/* L10: */ /* L10: */
} }
if (i__ == nd && *sqre == 0) { if (i__ == nd && *sqre == 0) {
sqrei = 0; sqrei = 0;
} else { } else {
sqrei = 1; sqrei = 1;
} }
idxqi += nlp1; idxqi += nlp1;
vfi += nlp1; vfi += nlp1;
vli += nlp1; vli += nlp1;
nrp1 = nr + sqrei; nrp1 = nr + sqrei;
if (*icompq == 0) { if (*icompq == 0) {
dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp, dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp,
(ftnlen)1); (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], & dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2], work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
&nr, &work[nwork2], info, (ftnlen)1); &nr, &work[nwork2], info, (ftnlen)1);
itemp = nwork1 + (nrp1 - 1) * smlszp; itemp = nwork1 + (nrp1 - 1) * smlszp;
dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
} else { } else {
dlaset_((char *)"A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu, ( dlaset_((char *)"A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu, (
ftnlen)1); ftnlen)1);
dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1],
ldu, (ftnlen)1); ldu, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], & dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf + vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf +
u_dim1], ldu, &work[nwork1], info, (ftnlen)1); u_dim1], ldu, &work[nwork1], info, (ftnlen)1);
dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1) dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1)
; ;
} }
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
i__2 = nr; i__2 = nr;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j; iwork[idxqi + j] = j;
/* L20: */ /* L20: */
} }
/* L30: */ /* L30: */
} }
@ -555,61 +555,61 @@ f"> */
j = pow_ii(&c__2, &nlvl); j = pow_ii(&c__2, &nlvl);
for (lvl = nlvl; lvl >= 1; --lvl) { for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1; lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on */ /* Find the first node LF and last node LL on */
/* the current level LVL. */ /* the current level LVL. */
if (lvl == 1) { if (lvl == 1) {
lf = 1; lf = 1;
ll = 1; ll = 1;
} else { } else {
i__1 = lvl - 1; i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1); lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1; ll = (lf << 1) - 1;
} }
i__1 = ll; i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) { for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1; im1 = i__ - 1;
ic = iwork[inode + im1]; ic = iwork[inode + im1];
nl = iwork[ndiml + im1]; nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1]; nr = iwork[ndimr + im1];
nlf = ic - nl; nlf = ic - nl;
nrf = ic + 1; nrf = ic + 1;
if (i__ == ll) { if (i__ == ll) {
sqrei = *sqre; sqrei = *sqre;
} else { } else {
sqrei = 1; sqrei = 1;
} }
vfi = vf + nlf - 1; vfi = vf + nlf - 1;
vli = vl + nlf - 1; vli = vl + nlf - 1;
idxqi = idxq + nlf - 1; idxqi = idxq + nlf - 1;
alpha = d__[ic]; alpha = d__[ic];
beta = e[ic]; beta = e[ic];
if (*icompq == 0) { if (*icompq == 0) {
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[ work[vli], &alpha, &beta, &iwork[idxqi], &perm[
perm_offset], &givptr[1], &givcol[givcol_offset], perm_offset], &givptr[1], &givcol[givcol_offset],
ldgcol, &givnum[givnum_offset], ldu, &poles[ ldgcol, &givnum[givnum_offset], ldu, &poles[
poles_offset], &difl[difl_offset], &difr[difr_offset], poles_offset], &difl[difl_offset], &difr[difr_offset],
&z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1], &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
&iwork[iwk], info); &iwork[iwk], info);
} else { } else {
--j; --j;
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf + work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf +
lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 *
givcol_dim1], ldgcol, &givnum[nlf + lvl2 * givcol_dim1], ldgcol, &givnum[nlf + lvl2 *
givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], & givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], &
difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 *
difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j], difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j],
&s[j], &work[nwork1], &iwork[iwk], info); &s[j], &work[nwork1], &iwork[iwk], info);
} }
if (*info != 0) { if (*info != 0) {
return 0; return 0;
} }
/* L40: */ /* L40: */
} }
/* L50: */ /* L50: */
} }
@ -620,5 +620,5 @@ f"> */
} /* dlasda_ */ } /* dlasda_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

252
lib/linalg/dlasdq.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasdq.f -- translated by f2c (version 20200916). /* fortran/dlasdq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -232,14 +232,14 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer * /* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer *
ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e, ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e,
doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, doublereal *u, integer *ldu,
doublereal *c__, integer *ldc, doublereal *work, integer *info, doublereal *c__, integer *ldc, doublereal *work, integer *info,
ftnlen uplo_len) ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2; i__2;
/* Local variables */ /* Local variables */
integer i__, j; integer i__, j;
@ -248,17 +248,17 @@ f"> */
doublereal smin; doublereal smin;
integer sqre1; integer sqre1;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen, ftnlen), dswap_(integer *, doublereal *, integer * ftnlen, ftnlen, ftnlen), dswap_(integer *, doublereal *, integer *
, doublereal *, integer *); , doublereal *, integer *);
integer iuplo; integer iuplo;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *, doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *, ftnlen), dbdsqr_(char *, integer *, integer *, integer integer *, ftnlen), dbdsqr_(char *, integer *, integer *, integer
*, integer *, doublereal *, doublereal *, doublereal *, integer *, *, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen); integer *, ftnlen);
logical rotate; logical rotate;
@ -305,37 +305,37 @@ f"> */
*info = 0; *info = 0;
iuplo = 0; iuplo = 0;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
iuplo = 1; iuplo = 1;
} }
if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
iuplo = 2; iuplo = 2;
} }
if (iuplo == 0) { if (iuplo == 0) {
*info = -1; *info = -1;
} else if (*sqre < 0 || *sqre > 1) { } else if (*sqre < 0 || *sqre > 1) {
*info = -2; *info = -2;
} else if (*n < 0) { } else if (*n < 0) {
*info = -3; *info = -3;
} else if (*ncvt < 0) { } else if (*ncvt < 0) {
*info = -4; *info = -4;
} else if (*nru < 0) { } else if (*nru < 0) {
*info = -5; *info = -5;
} else if (*ncc < 0) { } else if (*ncc < 0) {
*info = -6; *info = -6;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) { } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -10; *info = -10;
} else if (*ldu < max(1,*nru)) { } else if (*ldu < max(1,*nru)) {
*info = -12; *info = -12;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) { } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -14; *info = -14;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASDQ", &i__1, (ftnlen)6); xerbla_((char *)"DLASDQ", &i__1, (ftnlen)6);
return 0; return 0;
} }
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
/* ROTATE is true if any singular vectors desired, false otherwise */ /* ROTATE is true if any singular vectors desired, false otherwise */
@ -348,92 +348,92 @@ f"> */
/* bidiagonal. The rotations are on the right. */ /* bidiagonal. The rotations are on the right. */
if (iuplo == 1 && sqre1 == 1) { if (iuplo == 1 && sqre1 == 1) {
i__1 = *n - 1; i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__; d__[i__] = r__;
e[i__] = sn * d__[i__ + 1]; e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1]; d__[i__ + 1] = cs * d__[i__ + 1];
if (rotate) { if (rotate) {
work[i__] = cs; work[i__] = cs;
work[*n + i__] = sn; work[*n + i__] = sn;
} }
/* L10: */ /* L10: */
} }
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__; d__[*n] = r__;
e[*n] = 0.; e[*n] = 0.;
if (rotate) { if (rotate) {
work[*n] = cs; work[*n] = cs;
work[*n + *n] = sn; work[*n + *n] = sn;
} }
iuplo = 2; iuplo = 2;
sqre1 = 0; sqre1 = 0;
/* Update singular vectors if desired. */ /* Update singular vectors if desired. */
if (*ncvt > 0) { if (*ncvt > 0) {
dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncvt, &work[1], &work[np1], &vt[ dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncvt, &work[1], &work[np1], &vt[
vt_offset], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); vt_offset], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1);
} }
} }
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ /* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left. */ /* by applying Givens rotations on the left. */
if (iuplo == 2) { if (iuplo == 2) {
i__1 = *n - 1; i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__; d__[i__] = r__;
e[i__] = sn * d__[i__ + 1]; e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1]; d__[i__ + 1] = cs * d__[i__ + 1];
if (rotate) { if (rotate) {
work[i__] = cs; work[i__] = cs;
work[*n + i__] = sn; work[*n + i__] = sn;
} }
/* L20: */ /* L20: */
} }
/* If matrix (N+1)-by-N lower bidiagonal, one additional */ /* If matrix (N+1)-by-N lower bidiagonal, one additional */
/* rotation is needed. */ /* rotation is needed. */
if (sqre1 == 1) { if (sqre1 == 1) {
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__; d__[*n] = r__;
if (rotate) { if (rotate) {
work[*n] = cs; work[*n] = cs;
work[*n + *n] = sn; work[*n + *n] = sn;
} }
} }
/* Update singular vectors if desired. */ /* Update singular vectors if desired. */
if (*nru > 0) { if (*nru > 0) {
if (sqre1 == 0) { if (sqre1 == 0) {
dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[np1], &u[ dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[np1], &u[
u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1);
} else { } else {
dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &np1, &work[1], &work[np1], &u[ dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &np1, &work[1], &work[np1], &u[
u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1);
} }
} }
if (*ncc > 0) { if (*ncc > 0) {
if (sqre1 == 0) { if (sqre1 == 0) {
dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[np1], &c__[ dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[np1], &c__[
c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1);
} else { } else {
dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncc, &work[1], &work[np1], &c__[ dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncc, &work[1], &work[np1], &c__[
c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1);
} }
} }
} }
/* Call DBDSQR to compute the SVD of the reduced real */ /* Call DBDSQR to compute the SVD of the reduced real */
/* N-by-N upper bidiagonal matrix. */ /* N-by-N upper bidiagonal matrix. */
dbdsqr_((char *)"U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[ dbdsqr_((char *)"U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[
u_offset], ldu, &c__[c_offset], ldc, &work[1], info, (ftnlen)1); u_offset], ldu, &c__[c_offset], ldc, &work[1], info, (ftnlen)1);
/* Sort the singular values into ascending order (insertion sort on */ /* Sort the singular values into ascending order (insertion sort on */
/* singular values, but only one transposition per singular vector) */ /* singular values, but only one transposition per singular vector) */
@ -443,35 +443,35 @@ f"> */
/* Scan for smallest D(I). */ /* Scan for smallest D(I). */
isub = i__; isub = i__;
smin = d__[i__]; smin = d__[i__];
i__2 = *n; i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) { for (j = i__ + 1; j <= i__2; ++j) {
if (d__[j] < smin) { if (d__[j] < smin) {
isub = j; isub = j;
smin = d__[j]; smin = d__[j];
} }
/* L30: */ /* L30: */
} }
if (isub != i__) { if (isub != i__) {
/* Swap singular values and vectors. */ /* Swap singular values and vectors. */
d__[isub] = d__[i__]; d__[isub] = d__[i__];
d__[i__] = smin; d__[i__] = smin;
if (*ncvt > 0) { if (*ncvt > 0) {
dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1],
ldvt); ldvt);
} }
if (*nru > 0) { if (*nru > 0) {
dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1] dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1]
, &c__1); , &c__1);
} }
if (*ncc > 0) { if (*ncc > 0) {
dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc) dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc)
; ;
} }
} }
/* L40: */ /* L40: */
} }
@ -482,5 +482,5 @@ f"> */
} /* dlasdq_ */ } /* dlasdq_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

44
lib/linalg/dlasdt.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasdt.f -- translated by f2c (version 20200916). /* fortran/dlasdt.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -122,7 +122,7 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer * /* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer *
inode, integer *ndiml, integer *ndimr, integer *msub) inode, integer *ndiml, integer *ndimr, integer *msub)
{ {
/* System generated locals */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
@ -180,20 +180,20 @@ f"> */
/* Constructing the tree at (NLVL+1)-st level. The number of */ /* Constructing the tree at (NLVL+1)-st level. The number of */
/* nodes created on this level is LLST * 2. */ /* nodes created on this level is LLST * 2. */
i__2 = llst - 1; i__2 = llst - 1;
for (i__ = 0; i__ <= i__2; ++i__) { for (i__ = 0; i__ <= i__2; ++i__) {
il += 2; il += 2;
ir += 2; ir += 2;
ncrnt = llst + i__; ncrnt = llst + i__;
ndiml[il] = ndiml[ncrnt] / 2; ndiml[il] = ndiml[ncrnt] / 2;
ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1; ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1;
inode[il] = inode[ncrnt] - ndimr[il] - 1; inode[il] = inode[ncrnt] - ndimr[il] - 1;
ndiml[ir] = ndimr[ncrnt] / 2; ndiml[ir] = ndimr[ncrnt] / 2;
ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1; ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1;
inode[ir] = inode[ncrnt] + ndiml[ir] + 1; inode[ir] = inode[ncrnt] + ndiml[ir] + 1;
/* L10: */ /* L10: */
} }
llst <<= 1; llst <<= 1;
/* L20: */ /* L20: */
} }
*nd = (llst << 1) - 1; *nd = (llst << 1) - 1;
@ -205,5 +205,5 @@ f"> */
} /* dlasdt_ */ } /* dlasdt_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

64
lib/linalg/dlaset.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaset.f -- translated by f2c (version 20200916). /* fortran/dlaset.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -128,7 +128,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal * /* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal *
alpha, doublereal *beta, doublereal *a, integer *lda, ftnlen uplo_len) alpha, doublereal *beta, doublereal *a, integer *lda, ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -168,53 +168,53 @@ f"> */
/* Set the strictly upper triangular or trapezoidal part of the */ /* Set the strictly upper triangular or trapezoidal part of the */
/* array to ALPHA. */ /* array to ALPHA. */
i__1 = *n; i__1 = *n;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
/* Computing MIN */ /* Computing MIN */
i__3 = j - 1; i__3 = j - 1;
i__2 = min(i__3,*m); i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha; a[i__ + j * a_dim1] = *alpha;
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Set the strictly lower triangular or trapezoidal part of the */ /* Set the strictly lower triangular or trapezoidal part of the */
/* array to ALPHA. */ /* array to ALPHA. */
i__1 = min(*m,*n); i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) { for (i__ = j + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha; a[i__ + j * a_dim1] = *alpha;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
} else { } else {
/* Set the leading m-by-n submatrix to ALPHA. */ /* Set the leading m-by-n submatrix to ALPHA. */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha; a[i__ + j * a_dim1] = *alpha;
/* L50: */ /* L50: */
} }
/* L60: */ /* L60: */
} }
} }
/* Set the first min(M,N) diagonal elements to BETA. */ /* Set the first min(M,N) diagonal elements to BETA. */
i__1 = min(*m,*n); i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + i__ * a_dim1] = *beta; a[i__ + i__ * a_dim1] = *beta;
/* L70: */ /* L70: */
} }
@ -225,5 +225,5 @@ f"> */
} /* dlaset_ */ } /* dlaset_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

110
lib/linalg/dlasq1.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasq1.f -- translated by f2c (version 20200916). /* fortran/dlasq1.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -130,8 +130,8 @@ f"> */
/* > \ingroup auxOTHERcomputational */ /* > \ingroup auxOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e, /* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e,
doublereal *work, integer *info) doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
@ -143,22 +143,22 @@ f"> */
/* Local variables */ /* Local variables */
integer i__; integer i__;
doublereal eps; doublereal eps;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *); *, doublereal *, doublereal *);
doublereal scale; doublereal scale;
integer iinfo; integer iinfo;
doublereal sigmn; doublereal sigmn;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *); doublereal *, integer *);
doublereal sigmx; doublereal sigmx;
extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *); extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *, extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen); integer *, integer *, ftnlen);
doublereal safmin; doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlasrt_( extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlasrt_(
char *, integer *, doublereal *, integer *, ftnlen); char *, integer *, doublereal *, integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -192,20 +192,20 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*n < 0) { if (*n < 0) {
*info = -1; *info = -1;
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASQ1", &i__1, (ftnlen)6); xerbla_((char *)"DLASQ1", &i__1, (ftnlen)6);
return 0; return 0;
} else if (*n == 0) { } else if (*n == 0) {
return 0; return 0;
} else if (*n == 1) { } else if (*n == 1) {
d__[1] = abs(d__[1]); d__[1] = abs(d__[1]);
return 0; return 0;
} else if (*n == 2) { } else if (*n == 2) {
dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx);
d__[1] = sigmx; d__[1] = sigmx;
d__[2] = sigmn; d__[2] = sigmn;
return 0; return 0;
} }
/* Estimate the largest singular value. */ /* Estimate the largest singular value. */
@ -213,10 +213,10 @@ f"> */
sigmx = 0.; sigmx = 0.;
i__1 = *n - 1; i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = (d__1 = d__[i__], abs(d__1)); d__[i__] = (d__1 = d__[i__], abs(d__1));
/* Computing MAX */ /* Computing MAX */
d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1)); d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1));
sigmx = max(d__2,d__3); sigmx = max(d__2,d__3);
/* L10: */ /* L10: */
} }
d__[*n] = (d__1 = d__[*n], abs(d__1)); d__[*n] = (d__1 = d__[*n], abs(d__1));
@ -224,15 +224,15 @@ f"> */
/* Early return if SIGMX is zero (matrix is already diagonal). */ /* Early return if SIGMX is zero (matrix is already diagonal). */
if (sigmx == 0.) { if (sigmx == 0.) {
dlasrt_((char *)"D", n, &d__[1], &iinfo, (ftnlen)1); dlasrt_((char *)"D", n, &d__[1], &iinfo, (ftnlen)1);
return 0; return 0;
} }
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */ /* Computing MAX */
d__1 = sigmx, d__2 = d__[i__]; d__1 = sigmx, d__2 = d__[i__];
sigmx = max(d__1,d__2); sigmx = max(d__1,d__2);
/* L20: */ /* L20: */
} }
@ -247,16 +247,16 @@ f"> */
dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2); dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2);
i__1 = (*n << 1) - 1; i__1 = (*n << 1) - 1;
i__2 = (*n << 1) - 1; i__2 = (*n << 1) - 1;
dlascl_((char *)"G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, dlascl_((char *)"G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2,
&iinfo, (ftnlen)1); &iinfo, (ftnlen)1);
/* Compute the q's and e's. */ /* Compute the q's and e's. */
i__1 = (*n << 1) - 1; i__1 = (*n << 1) - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = work[i__]; d__1 = work[i__];
work[i__] = d__1 * d__1; work[i__] = d__1 * d__1;
/* L30: */ /* L30: */
} }
work[*n * 2] = 0.; work[*n * 2] = 0.;
@ -264,27 +264,27 @@ f"> */
dlasq2_(n, &work[1], info); dlasq2_(n, &work[1], info);
if (*info == 0) { if (*info == 0) {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(work[i__]); d__[i__] = sqrt(work[i__]);
/* L40: */ /* L40: */
} }
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
iinfo, (ftnlen)1); iinfo, (ftnlen)1);
} else if (*info == 2) { } else if (*info == 2) {
/* Maximum number of iterations exceeded. Move data from WORK */ /* Maximum number of iterations exceeded. Move data from WORK */
/* into D and E so the calling subroutine can try to finish */ /* into D and E so the calling subroutine can try to finish */
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(work[(i__ << 1) - 1]); d__[i__] = sqrt(work[(i__ << 1) - 1]);
e[i__] = sqrt(work[i__ * 2]); e[i__] = sqrt(work[i__ * 2]);
} }
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
iinfo, (ftnlen)1); iinfo, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo, dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo,
(ftnlen)1); (ftnlen)1);
} }
return 0; return 0;
@ -294,5 +294,5 @@ f"> */
} /* dlasq1_ */ } /* dlasq1_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

586
lib/linalg/dlasq2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasq2.f -- translated by f2c (version 20200916). /* fortran/dlasq2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -168,20 +168,20 @@ f"> */
integer iinfo; integer iinfo;
doublereal tempe, tempq; doublereal tempe, tempq;
integer ttype; integer ttype;
extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, logical *, integer *, integer *, integer *, integer *, logical *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *); doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
doublereal deemin; doublereal deemin;
integer iwhila, iwhilb; integer iwhila, iwhilb;
doublereal oldemn, safmin; doublereal oldemn, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen); integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -223,57 +223,57 @@ f"> */
tol2 = d__1 * d__1; tol2 = d__1 * d__1;
if (*n < 0) { if (*n < 0) {
*info = -1; *info = -1;
xerbla_((char *)"DLASQ2", &c__1, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__1, (ftnlen)6);
return 0; return 0;
} else if (*n == 0) { } else if (*n == 0) {
return 0; return 0;
} else if (*n == 1) { } else if (*n == 1) {
/* 1-by-1 case. */ /* 1-by-1 case. */
if (z__[1] < 0.) { if (z__[1] < 0.) {
*info = -201; *info = -201;
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
} }
return 0; return 0;
} else if (*n == 2) { } else if (*n == 2) {
/* 2-by-2 case. */ /* 2-by-2 case. */
if (z__[1] < 0.) { if (z__[1] < 0.) {
*info = -201; *info = -201;
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
return 0; return 0;
} else if (z__[2] < 0.) { } else if (z__[2] < 0.) {
*info = -202; *info = -202;
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
return 0; return 0;
} else if (z__[3] < 0.) { } else if (z__[3] < 0.) {
*info = -203; *info = -203;
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
return 0; return 0;
} else if (z__[3] > z__[1]) { } else if (z__[3] > z__[1]) {
d__ = z__[3]; d__ = z__[3];
z__[3] = z__[1]; z__[3] = z__[1];
z__[1] = d__; z__[1] = d__;
} }
z__[5] = z__[1] + z__[2] + z__[3]; z__[5] = z__[1] + z__[2] + z__[3];
if (z__[2] > z__[3] * tol2) { if (z__[2] > z__[3] * tol2) {
t = (z__[1] - z__[3] + z__[2]) * .5; t = (z__[1] - z__[3] + z__[2]) * .5;
s = z__[3] * (z__[2] / t); s = z__[3] * (z__[2] / t);
if (s <= t) { if (s <= t) {
s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.))); s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.)));
} else { } else {
s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s)));
} }
t = z__[1] + (s + z__[2]); t = z__[1] + (s + z__[2]);
z__[3] *= z__[1] / t; z__[3] *= z__[1] / t;
z__[1] = t; z__[1] = t;
} }
z__[2] = z__[3]; z__[2] = z__[3];
z__[6] = z__[2] + z__[1]; z__[6] = z__[2] + z__[1];
return 0; return 0;
} }
/* Check for negative data and compute sums of q's and e's. */ /* Check for negative data and compute sums of q's and e's. */
@ -287,32 +287,32 @@ f"> */
i__1 = *n - 1 << 1; i__1 = *n - 1 << 1;
for (k = 1; k <= i__1; k += 2) { for (k = 1; k <= i__1; k += 2) {
if (z__[k] < 0.) { if (z__[k] < 0.) {
*info = -(k + 200); *info = -(k + 200);
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
return 0; return 0;
} else if (z__[k + 1] < 0.) { } else if (z__[k + 1] < 0.) {
*info = -(k + 201); *info = -(k + 201);
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
return 0; return 0;
} }
d__ += z__[k]; d__ += z__[k];
e += z__[k + 1]; e += z__[k + 1];
/* Computing MAX */ /* Computing MAX */
d__1 = qmax, d__2 = z__[k]; d__1 = qmax, d__2 = z__[k];
qmax = max(d__1,d__2); qmax = max(d__1,d__2);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[k + 1]; d__1 = emin, d__2 = z__[k + 1];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* Computing MAX */ /* Computing MAX */
d__1 = max(qmax,zmax), d__2 = z__[k + 1]; d__1 = max(qmax,zmax), d__2 = z__[k + 1];
zmax = max(d__1,d__2); zmax = max(d__1,d__2);
/* L10: */ /* L10: */
} }
if (z__[(*n << 1) - 1] < 0.) { if (z__[(*n << 1) - 1] < 0.) {
*info = -((*n << 1) + 199); *info = -((*n << 1) + 199);
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
return 0; return 0;
} }
d__ += z__[(*n << 1) - 1]; d__ += z__[(*n << 1) - 1];
/* Computing MAX */ /* Computing MAX */
@ -323,14 +323,14 @@ f"> */
/* Check for diagonality. */ /* Check for diagonality. */
if (e == 0.) { if (e == 0.) {
i__1 = *n; i__1 = *n;
for (k = 2; k <= i__1; ++k) { for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 1) - 1]; z__[k] = z__[(k << 1) - 1];
/* L20: */ /* L20: */
} }
dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1); dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1);
z__[(*n << 1) - 1] = d__; z__[(*n << 1) - 1] = d__;
return 0; return 0;
} }
trace = d__ + e; trace = d__ + e;
@ -338,22 +338,22 @@ f"> */
/* Check for zero data. */ /* Check for zero data. */
if (trace == 0.) { if (trace == 0.) {
z__[(*n << 1) - 1] = 0.; z__[(*n << 1) - 1] = 0.;
return 0; return 0;
} }
/* Check whether the machine is IEEE conformable. */ /* Check whether the machine is IEEE conformable. */
ieee = ilaenv_(&c__10, (char *)"DLASQ2", (char *)"N", &c__1, &c__2, &c__3, &c__4, (ftnlen) ieee = ilaenv_(&c__10, (char *)"DLASQ2", (char *)"N", &c__1, &c__2, &c__3, &c__4, (ftnlen)
6, (ftnlen)1) == 1; 6, (ftnlen)1) == 1;
/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */ /* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */
for (k = *n << 1; k >= 2; k += -2) { for (k = *n << 1; k >= 2; k += -2) {
z__[k * 2] = 0.; z__[k * 2] = 0.;
z__[(k << 1) - 1] = z__[k]; z__[(k << 1) - 1] = z__[k];
z__[(k << 1) - 2] = 0.; z__[(k << 1) - 2] = 0.;
z__[(k << 1) - 3] = z__[k - 1]; z__[(k << 1) - 3] = z__[k - 1];
/* L30: */ /* L30: */
} }
@ -363,17 +363,17 @@ f"> */
/* Reverse the qd-array, if warranted. */ /* Reverse the qd-array, if warranted. */
if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) { if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) {
ipn4 = i0 + n0 << 2; ipn4 = i0 + n0 << 2;
i__1 = i0 + n0 - 1 << 1; i__1 = i0 + n0 - 1 << 1;
for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { for (i4 = i0 << 2; i4 <= i__1; i4 += 4) {
temp = z__[i4 - 3]; temp = z__[i4 - 3];
z__[i4 - 3] = z__[ipn4 - i4 - 3]; z__[i4 - 3] = z__[ipn4 - i4 - 3];
z__[ipn4 - i4 - 3] = temp; z__[ipn4 - i4 - 3] = temp;
temp = z__[i4 - 1]; temp = z__[i4 - 1];
z__[i4 - 1] = z__[ipn4 - i4 - 5]; z__[i4 - 1] = z__[ipn4 - i4 - 5];
z__[ipn4 - i4 - 5] = temp; z__[ipn4 - i4 - 5] = temp;
/* L40: */ /* L40: */
} }
} }
/* Initial split checking via dqd and Li's test. */ /* Initial split checking via dqd and Li's test. */
@ -382,61 +382,61 @@ f"> */
for (k = 1; k <= 2; ++k) { for (k = 1; k <= 2; ++k) {
d__ = z__[(n0 << 2) + pp - 3]; d__ = z__[(n0 << 2) + pp - 3];
i__1 = (i0 << 2) + pp; i__1 = (i0 << 2) + pp;
for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) { for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) {
if (z__[i4 - 1] <= tol2 * d__) { if (z__[i4 - 1] <= tol2 * d__) {
z__[i4 - 1] = -0.; z__[i4 - 1] = -0.;
d__ = z__[i4 - 3]; d__ = z__[i4 - 3];
} else { } else {
d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1]));
} }
/* L50: */ /* L50: */
} }
/* dqd maps Z to ZZ plus Li's test. */ /* dqd maps Z to ZZ plus Li's test. */
emin = z__[(i0 << 2) + pp + 1]; emin = z__[(i0 << 2) + pp + 1];
d__ = z__[(i0 << 2) + pp - 3]; d__ = z__[(i0 << 2) + pp - 3];
i__1 = (n0 - 1 << 2) + pp; i__1 = (n0 - 1 << 2) + pp;
for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) {
z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1];
if (z__[i4 - 1] <= tol2 * d__) { if (z__[i4 - 1] <= tol2 * d__) {
z__[i4 - 1] = -0.; z__[i4 - 1] = -0.;
z__[i4 - (pp << 1) - 2] = d__; z__[i4 - (pp << 1) - 2] = d__;
z__[i4 - (pp << 1)] = 0.; z__[i4 - (pp << 1)] = 0.;
d__ = z__[i4 + 1]; d__ = z__[i4 + 1];
} else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] &&
safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) {
temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2];
z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; z__[i4 - (pp << 1)] = z__[i4 - 1] * temp;
d__ *= temp; d__ *= temp;
} else { } else {
z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - ( z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (
pp << 1) - 2]); pp << 1) - 2]);
d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]);
} }
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[i4 - (pp << 1)]; d__1 = emin, d__2 = z__[i4 - (pp << 1)];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L60: */ /* L60: */
} }
z__[(n0 << 2) - pp - 2] = d__; z__[(n0 << 2) - pp - 2] = d__;
/* Now find qmax. */ /* Now find qmax. */
qmax = z__[(i0 << 2) - pp - 2]; qmax = z__[(i0 << 2) - pp - 2];
i__1 = (n0 << 2) - pp - 2; i__1 = (n0 << 2) - pp - 2;
for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) {
/* Computing MAX */ /* Computing MAX */
d__1 = qmax, d__2 = z__[i4]; d__1 = qmax, d__2 = z__[i4];
qmax = max(d__1,d__2); qmax = max(d__1,d__2);
/* L70: */ /* L70: */
} }
/* Prepare for the next iteration on K. */ /* Prepare for the next iteration on K. */
pp = 1 - pp; pp = 1 - pp;
/* L80: */ /* L80: */
} }
@ -457,104 +457,104 @@ f"> */
i__1 = *n + 1; i__1 = *n + 1;
for (iwhila = 1; iwhila <= i__1; ++iwhila) { for (iwhila = 1; iwhila <= i__1; ++iwhila) {
if (n0 < 1) { if (n0 < 1) {
goto L170; goto L170;
} }
/* While array unfinished do */ /* While array unfinished do */
/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */ /* E(N0) holds the value of SIGMA when submatrix in I0:N0 */
/* splits from the rest of the array, but is negated. */ /* splits from the rest of the array, but is negated. */
desig = 0.; desig = 0.;
if (n0 == *n) { if (n0 == *n) {
sigma = 0.; sigma = 0.;
} else { } else {
sigma = -z__[(n0 << 2) - 1]; sigma = -z__[(n0 << 2) - 1];
} }
if (sigma < 0.) { if (sigma < 0.) {
*info = 1; *info = 1;
return 0; return 0;
} }
/* Find last unreduced submatrix's top index I0, find QMAX and */ /* Find last unreduced submatrix's top index I0, find QMAX and */
/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */ /* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */
emax = 0.; emax = 0.;
if (n0 > i0) { if (n0 > i0) {
emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1)); emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1));
} else { } else {
emin = 0.; emin = 0.;
} }
qmin = z__[(n0 << 2) - 3]; qmin = z__[(n0 << 2) - 3];
qmax = qmin; qmax = qmin;
for (i4 = n0 << 2; i4 >= 8; i4 += -4) { for (i4 = n0 << 2; i4 >= 8; i4 += -4) {
if (z__[i4 - 5] <= 0.) { if (z__[i4 - 5] <= 0.) {
goto L100; goto L100;
} }
if (qmin >= emax * 4.) { if (qmin >= emax * 4.) {
/* Computing MIN */ /* Computing MIN */
d__1 = qmin, d__2 = z__[i4 - 3]; d__1 = qmin, d__2 = z__[i4 - 3];
qmin = min(d__1,d__2); qmin = min(d__1,d__2);
/* Computing MAX */ /* Computing MAX */
d__1 = emax, d__2 = z__[i4 - 5]; d__1 = emax, d__2 = z__[i4 - 5];
emax = max(d__1,d__2); emax = max(d__1,d__2);
} }
/* Computing MAX */ /* Computing MAX */
d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5]; d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5];
qmax = max(d__1,d__2); qmax = max(d__1,d__2);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[i4 - 5]; d__1 = emin, d__2 = z__[i4 - 5];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L90: */ /* L90: */
} }
i4 = 4; i4 = 4;
L100: L100:
i0 = i4 / 4; i0 = i4 / 4;
pp = 0; pp = 0;
if (n0 - i0 > 1) { if (n0 - i0 > 1) {
dee = z__[(i0 << 2) - 3]; dee = z__[(i0 << 2) - 3];
deemin = dee; deemin = dee;
kmin = i0; kmin = i0;
i__2 = (n0 << 2) - 3; i__2 = (n0 << 2) - 3;
for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) { for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) {
dee = z__[i4] * (dee / (dee + z__[i4 - 2])); dee = z__[i4] * (dee / (dee + z__[i4 - 2]));
if (dee <= deemin) { if (dee <= deemin) {
deemin = dee; deemin = dee;
kmin = (i4 + 3) / 4; kmin = (i4 + 3) / 4;
} }
/* L110: */ /* L110: */
} }
if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] *
.5) { .5) {
ipn4 = i0 + n0 << 2; ipn4 = i0 + n0 << 2;
pp = 2; pp = 2;
i__2 = i0 + n0 - 1 << 1; i__2 = i0 + n0 - 1 << 1;
for (i4 = i0 << 2; i4 <= i__2; i4 += 4) { for (i4 = i0 << 2; i4 <= i__2; i4 += 4) {
temp = z__[i4 - 3]; temp = z__[i4 - 3];
z__[i4 - 3] = z__[ipn4 - i4 - 3]; z__[i4 - 3] = z__[ipn4 - i4 - 3];
z__[ipn4 - i4 - 3] = temp; z__[ipn4 - i4 - 3] = temp;
temp = z__[i4 - 2]; temp = z__[i4 - 2];
z__[i4 - 2] = z__[ipn4 - i4 - 2]; z__[i4 - 2] = z__[ipn4 - i4 - 2];
z__[ipn4 - i4 - 2] = temp; z__[ipn4 - i4 - 2] = temp;
temp = z__[i4 - 1]; temp = z__[i4 - 1];
z__[i4 - 1] = z__[ipn4 - i4 - 5]; z__[i4 - 1] = z__[ipn4 - i4 - 5];
z__[ipn4 - i4 - 5] = temp; z__[ipn4 - i4 - 5] = temp;
temp = z__[i4]; temp = z__[i4];
z__[i4] = z__[ipn4 - i4 - 4]; z__[i4] = z__[ipn4 - i4 - 4];
z__[ipn4 - i4 - 4] = temp; z__[ipn4 - i4 - 4] = temp;
/* L120: */ /* L120: */
} }
} }
} }
/* Put -(initial shift) into DMIN. */ /* Put -(initial shift) into DMIN. */
/* Computing MAX */ /* Computing MAX */
d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax); d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax);
dmin__ = -max(d__1,d__2); dmin__ = -max(d__1,d__2);
/* Now I0:N0 is unreduced. */ /* Now I0:N0 is unreduced. */
/* PP = 0 for ping, PP = 1 for pong. */ /* PP = 0 for ping, PP = 1 for pong. */
@ -562,113 +562,113 @@ L100:
/* and that the tests for deflation upon entry in DLASQ3 */ /* and that the tests for deflation upon entry in DLASQ3 */
/* should not be performed. */ /* should not be performed. */
nbig = (n0 - i0 + 1) * 100; nbig = (n0 - i0 + 1) * 100;
i__2 = nbig; i__2 = nbig;
for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) {
if (i0 > n0) { if (i0 > n0) {
goto L150; goto L150;
} }
/* While submatrix unfinished take a good dqds step. */ /* While submatrix unfinished take a good dqds step. */
dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, & dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &
nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, & nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &
dn1, &dn2, &g, &tau); dn1, &dn2, &g, &tau);
pp = 1 - pp; pp = 1 - pp;
/* When EMIN is very small check for splits. */ /* When EMIN is very small check for splits. */
if (pp == 0 && n0 - i0 >= 3) { if (pp == 0 && n0 - i0 >= 3) {
if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 *
sigma) { sigma) {
splt = i0 - 1; splt = i0 - 1;
qmax = z__[(i0 << 2) - 3]; qmax = z__[(i0 << 2) - 3];
emin = z__[(i0 << 2) - 1]; emin = z__[(i0 << 2) - 1];
oldemn = z__[i0 * 4]; oldemn = z__[i0 * 4];
i__3 = n0 - 3 << 2; i__3 = n0 - 3 << 2;
for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { for (i4 = i0 << 2; i4 <= i__3; i4 += 4) {
if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <=
tol2 * sigma) { tol2 * sigma) {
z__[i4 - 1] = -sigma; z__[i4 - 1] = -sigma;
splt = i4 / 4; splt = i4 / 4;
qmax = 0.; qmax = 0.;
emin = z__[i4 + 3]; emin = z__[i4 + 3];
oldemn = z__[i4 + 4]; oldemn = z__[i4 + 4];
} else { } else {
/* Computing MAX */ /* Computing MAX */
d__1 = qmax, d__2 = z__[i4 + 1]; d__1 = qmax, d__2 = z__[i4 + 1];
qmax = max(d__1,d__2); qmax = max(d__1,d__2);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[i4 - 1]; d__1 = emin, d__2 = z__[i4 - 1];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* Computing MIN */ /* Computing MIN */
d__1 = oldemn, d__2 = z__[i4]; d__1 = oldemn, d__2 = z__[i4];
oldemn = min(d__1,d__2); oldemn = min(d__1,d__2);
} }
/* L130: */ /* L130: */
} }
z__[(n0 << 2) - 1] = emin; z__[(n0 << 2) - 1] = emin;
z__[n0 * 4] = oldemn; z__[n0 * 4] = oldemn;
i0 = splt + 1; i0 = splt + 1;
} }
} }
/* L140: */ /* L140: */
} }
*info = 2; *info = 2;
/* Maximum number of iterations exceeded, restore the shift */ /* Maximum number of iterations exceeded, restore the shift */
/* SIGMA and place the new d's and e's in a qd array. */ /* SIGMA and place the new d's and e's in a qd array. */
/* This might need to be done for several blocks */ /* This might need to be done for several blocks */
i1 = i0; i1 = i0;
n1 = n0; n1 = n0;
L145: L145:
tempq = z__[(i0 << 2) - 3]; tempq = z__[(i0 << 2) - 3];
z__[(i0 << 2) - 3] += sigma; z__[(i0 << 2) - 3] += sigma;
i__2 = n0; i__2 = n0;
for (k = i0 + 1; k <= i__2; ++k) { for (k = i0 + 1; k <= i__2; ++k) {
tempe = z__[(k << 2) - 5]; tempe = z__[(k << 2) - 5];
z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7]; z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7];
tempq = z__[(k << 2) - 3]; tempq = z__[(k << 2) - 3];
z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k << z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k <<
2) - 5]; 2) - 5];
} }
/* Prepare to do this on the previous block if there is one */ /* Prepare to do this on the previous block if there is one */
if (i1 > 1) { if (i1 > 1) {
n1 = i1 - 1; n1 = i1 - 1;
while(i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) { while(i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) {
--i1; --i1;
} }
sigma = -z__[(n1 << 2) - 1]; sigma = -z__[(n1 << 2) - 1];
goto L145; goto L145;
} }
i__2 = *n; i__2 = *n;
for (k = 1; k <= i__2; ++k) { for (k = 1; k <= i__2; ++k) {
z__[(k << 1) - 1] = z__[(k << 2) - 3]; z__[(k << 1) - 1] = z__[(k << 2) - 3];
/* Only the block 1..N0 is unfinished. The rest of the e's */ /* Only the block 1..N0 is unfinished. The rest of the e's */
/* must be essentially zero, although sometimes other data */ /* must be essentially zero, although sometimes other data */
/* has been stored in them. */ /* has been stored in them. */
if (k < n0) { if (k < n0) {
z__[k * 2] = z__[(k << 2) - 1]; z__[k * 2] = z__[(k << 2) - 1];
} else { } else {
z__[k * 2] = 0.; z__[k * 2] = 0.;
} }
} }
return 0; return 0;
/* end IWHILB */ /* end IWHILB */
L150: L150:
/* L160: */ /* L160: */
; ;
} }
*info = 3; *info = 3;
@ -682,7 +682,7 @@ L170:
i__1 = *n; i__1 = *n;
for (k = 2; k <= i__1; ++k) { for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 2) - 3]; z__[k] = z__[(k << 2) - 3];
/* L180: */ /* L180: */
} }
@ -692,7 +692,7 @@ L170:
e = 0.; e = 0.;
for (k = *n; k >= 1; --k) { for (k = *n; k >= 1; --k) {
e += z__[k]; e += z__[k];
/* L190: */ /* L190: */
} }
@ -712,5 +712,5 @@ L170:
} /* dlasq2_ */ } /* dlasq2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

222
lib/linalg/dlasq3.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasq3.f -- translated by f2c (version 20200916). /* fortran/dlasq3.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -196,12 +196,12 @@ f"> */
/* > \ingroup auxOTHERcomputational */ /* > \ingroup auxOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__, /* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig, integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig,
doublereal *qmax, integer *nfail, integer *iter, integer *ndiv, doublereal *qmax, integer *nfail, integer *iter, integer *ndiv,
logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2, logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g, doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g,
doublereal *tau) doublereal *tau)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -216,15 +216,15 @@ f"> */
doublereal eps, tol; doublereal eps, tol;
integer n0in, ipn4; integer n0in, ipn4;
doublereal tol2, temp; doublereal tol2, temp;
extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *, extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *), dlasq5_(integer *, integer *, doublereal *, doublereal *), dlasq5_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, logical * doublereal *, doublereal *, doublereal *, doublereal *, logical *
, doublereal *), dlasq6_(integer *, integer *, doublereal *, , doublereal *), dlasq6_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *); doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen); extern doublereal dlamch_(char *, ftnlen);
extern logical disnan_(doublereal *); extern logical disnan_(doublereal *);
@ -268,21 +268,21 @@ f"> */
L10: L10:
if (*n0 < *i0) { if (*n0 < *i0) {
return 0; return 0;
} }
if (*n0 == *i0) { if (*n0 == *i0) {
goto L20; goto L20;
} }
nn = (*n0 << 2) + *pp; nn = (*n0 << 2) + *pp;
if (*n0 == *i0 + 1) { if (*n0 == *i0 + 1) {
goto L40; goto L40;
} }
/* Check whether E(N0-1) is negligible, 1 eigenvalue. */ /* Check whether E(N0-1) is negligible, 1 eigenvalue. */
if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
4] > tol2 * z__[nn - 7]) { 4] > tol2 * z__[nn - 7]) {
goto L30; goto L30;
} }
L20: L20:
@ -296,28 +296,28 @@ L20:
L30: L30:
if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
nn - 11]) { nn - 11]) {
goto L50; goto L50;
} }
L40: L40:
if (z__[nn - 3] > z__[nn - 7]) { if (z__[nn - 3] > z__[nn - 7]) {
s = z__[nn - 3]; s = z__[nn - 3];
z__[nn - 3] = z__[nn - 7]; z__[nn - 3] = z__[nn - 7];
z__[nn - 7] = s; z__[nn - 7] = s;
} }
t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5;
if (z__[nn - 5] > z__[nn - 3] * tol2 && t != 0.) { if (z__[nn - 5] > z__[nn - 3] * tol2 && t != 0.) {
s = z__[nn - 3] * (z__[nn - 5] / t); s = z__[nn - 3] * (z__[nn - 5] / t);
if (s <= t) { if (s <= t) {
s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.)));
} else { } else {
s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
} }
t = z__[nn - 7] + (s + z__[nn - 5]); t = z__[nn - 7] + (s + z__[nn - 5]);
z__[nn - 3] *= z__[nn - 7] / t; z__[nn - 3] *= z__[nn - 7] / t;
z__[nn - 7] = t; z__[nn - 7] = t;
} }
z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
@ -326,64 +326,64 @@ L40:
L50: L50:
if (*pp == 2) { if (*pp == 2) {
*pp = 0; *pp = 0;
} }
/* Reverse the qd-array, if warranted. */ /* Reverse the qd-array, if warranted. */
if (*dmin__ <= 0. || *n0 < n0in) { if (*dmin__ <= 0. || *n0 < n0in) {
if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) {
ipn4 = *i0 + *n0 << 2; ipn4 = *i0 + *n0 << 2;
i__1 = *i0 + *n0 - 1 << 1; i__1 = *i0 + *n0 - 1 << 1;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
temp = z__[j4 - 3]; temp = z__[j4 - 3];
z__[j4 - 3] = z__[ipn4 - j4 - 3]; z__[j4 - 3] = z__[ipn4 - j4 - 3];
z__[ipn4 - j4 - 3] = temp; z__[ipn4 - j4 - 3] = temp;
temp = z__[j4 - 2]; temp = z__[j4 - 2];
z__[j4 - 2] = z__[ipn4 - j4 - 2]; z__[j4 - 2] = z__[ipn4 - j4 - 2];
z__[ipn4 - j4 - 2] = temp; z__[ipn4 - j4 - 2] = temp;
temp = z__[j4 - 1]; temp = z__[j4 - 1];
z__[j4 - 1] = z__[ipn4 - j4 - 5]; z__[j4 - 1] = z__[ipn4 - j4 - 5];
z__[ipn4 - j4 - 5] = temp; z__[ipn4 - j4 - 5] = temp;
temp = z__[j4]; temp = z__[j4];
z__[j4] = z__[ipn4 - j4 - 4]; z__[j4] = z__[ipn4 - j4 - 4];
z__[ipn4 - j4 - 4] = temp; z__[ipn4 - j4 - 4] = temp;
/* L60: */ /* L60: */
} }
if (*n0 - *i0 <= 4) { if (*n0 - *i0 <= 4) {
z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
} }
/* Computing MIN */ /* Computing MIN */
d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1];
*dmin2 = min(d__1,d__2); *dmin2 = min(d__1,d__2);
/* Computing MIN */ /* Computing MIN */
d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1]
, d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; , d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3];
z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2); z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2);
/* Computing MIN */ /* Computing MIN */
d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 =
min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4];
z__[(*n0 << 2) - *pp] = min(d__1,d__2); z__[(*n0 << 2) - *pp] = min(d__1,d__2);
/* Computing MAX */ /* Computing MAX */
d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1, d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1,
d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; d__2), d__2 = z__[(*i0 << 2) + *pp + 1];
*qmax = max(d__1,d__2); *qmax = max(d__1,d__2);
*dmin__ = -0.; *dmin__ = -0.;
} }
} }
/* Choose a shift. */ /* Choose a shift. */
dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
tau, ttype, g); tau, ttype, g);
/* Call dqds until DMIN > 0. */ /* Call dqds until DMIN > 0. */
L70: L70:
dlasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1, dlasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1,
dn2, ieee, &eps); dn2, ieee, &eps);
*ndiv += *n0 - *i0 + 2; *ndiv += *n0 - *i0 + 2;
++(*iter); ++(*iter);
@ -394,55 +394,55 @@ L70:
/* Success. */ /* Success. */
goto L90; goto L90;
} else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol
* (*sigma + *dn1) && abs(*dn) < tol * *sigma) { * (*sigma + *dn1) && abs(*dn) < tol * *sigma) {
/* Convergence hidden by negative DN. */ /* Convergence hidden by negative DN. */
z__[(*n0 - 1 << 2) - *pp + 2] = 0.; z__[(*n0 - 1 << 2) - *pp + 2] = 0.;
*dmin__ = 0.; *dmin__ = 0.;
goto L90; goto L90;
} else if (*dmin__ < 0.) { } else if (*dmin__ < 0.) {
/* TAU too big. Select new TAU and try again. */ /* TAU too big. Select new TAU and try again. */
++(*nfail); ++(*nfail);
if (*ttype < -22) { if (*ttype < -22) {
/* Failed twice. Play it safe. */ /* Failed twice. Play it safe. */
*tau = 0.; *tau = 0.;
} else if (*dmin1 > 0.) { } else if (*dmin1 > 0.) {
/* Late failure. Gives excellent shift. */ /* Late failure. Gives excellent shift. */
*tau = (*tau + *dmin__) * (1. - eps * 2.); *tau = (*tau + *dmin__) * (1. - eps * 2.);
*ttype += -11; *ttype += -11;
} else { } else {
/* Early failure. Divide by 4. */ /* Early failure. Divide by 4. */
*tau *= .25; *tau *= .25;
*ttype += -12; *ttype += -12;
} }
goto L70; goto L70;
} else if (disnan_(dmin__)) { } else if (disnan_(dmin__)) {
/* NaN. */ /* NaN. */
if (*tau == 0.) { if (*tau == 0.) {
goto L80; goto L80;
} else { } else {
*tau = 0.; *tau = 0.;
goto L70; goto L70;
} }
} else { } else {
/* Possible underflow. Play it safe. */ /* Possible underflow. Play it safe. */
goto L80; goto L80;
} }
/* Risk of underflow. */ /* Risk of underflow. */
@ -455,12 +455,12 @@ L80:
L90: L90:
if (*tau < *sigma) { if (*tau < *sigma) {
*desig += *tau; *desig += *tau;
t = *sigma + *desig; t = *sigma + *desig;
*desig -= t - *sigma; *desig -= t - *sigma;
} else { } else {
t = *sigma + *tau; t = *sigma + *tau;
*desig = *sigma - (t - *tau) + *desig; *desig = *sigma - (t - *tau) + *desig;
} }
*sigma = t; *sigma = t;
@ -471,5 +471,5 @@ L90:
} /* dlasq3_ */ } /* dlasq3_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

430
lib/linalg/dlasq4.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasq4.f -- translated by f2c (version 20200916). /* fortran/dlasq4.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -167,10 +167,10 @@ f"> */
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__, /* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__,
integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1, integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1,
doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2,
doublereal *tau, integer *ttype, doublereal *g) doublereal *tau, integer *ttype, doublereal *g)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -212,9 +212,9 @@ f"> */
/* Function Body */ /* Function Body */
if (*dmin__ <= 0.) { if (*dmin__ <= 0.) {
*tau = -(*dmin__); *tau = -(*dmin__);
*ttype = -1; *ttype = -1;
return 0; return 0;
} }
nn = (*n0 << 2) + *pp; nn = (*n0 << 2) + *pp;
@ -222,215 +222,215 @@ f"> */
/* No eigenvalues deflated. */ /* No eigenvalues deflated. */
if (*dmin__ == *dn || *dmin__ == *dn1) { if (*dmin__ == *dn || *dmin__ == *dn1) {
b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
a2 = z__[nn - 7] + z__[nn - 5]; a2 = z__[nn - 7] + z__[nn - 5];
/* Cases 2 and 3. */ /* Cases 2 and 3. */
if (*dmin__ == *dn && *dmin1 == *dn1) { if (*dmin__ == *dn && *dmin1 == *dn1) {
gap2 = *dmin2 - a2 - *dmin2 * .25; gap2 = *dmin2 - a2 - *dmin2 * .25;
if (gap2 > 0. && gap2 > b2) { if (gap2 > 0. && gap2 > b2) {
gap1 = a2 - *dn - b2 / gap2 * b2; gap1 = a2 - *dn - b2 / gap2 * b2;
} else { } else {
gap1 = a2 - *dn - (b1 + b2); gap1 = a2 - *dn - (b1 + b2);
} }
if (gap1 > 0. && gap1 > b1) { if (gap1 > 0. && gap1 > b1) {
/* Computing MAX */ /* Computing MAX */
d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5;
s = max(d__1,d__2); s = max(d__1,d__2);
*ttype = -2; *ttype = -2;
} else { } else {
s = 0.; s = 0.;
if (*dn > b1) { if (*dn > b1) {
s = *dn - b1; s = *dn - b1;
} }
if (a2 > b1 + b2) { if (a2 > b1 + b2) {
/* Computing MIN */ /* Computing MIN */
d__1 = s, d__2 = a2 - (b1 + b2); d__1 = s, d__2 = a2 - (b1 + b2);
s = min(d__1,d__2); s = min(d__1,d__2);
} }
/* Computing MAX */ /* Computing MAX */
d__1 = s, d__2 = *dmin__ * .333; d__1 = s, d__2 = *dmin__ * .333;
s = max(d__1,d__2); s = max(d__1,d__2);
*ttype = -3; *ttype = -3;
} }
} else { } else {
/* Case 4. */ /* Case 4. */
*ttype = -4; *ttype = -4;
s = *dmin__ * .25; s = *dmin__ * .25;
if (*dmin__ == *dn) { if (*dmin__ == *dn) {
gam = *dn; gam = *dn;
a2 = 0.; a2 = 0.;
if (z__[nn - 5] > z__[nn - 7]) { if (z__[nn - 5] > z__[nn - 7]) {
return 0; return 0;
} }
b2 = z__[nn - 5] / z__[nn - 7]; b2 = z__[nn - 5] / z__[nn - 7];
np = nn - 9; np = nn - 9;
} else { } else {
np = nn - (*pp << 1); np = nn - (*pp << 1);
gam = *dn1; gam = *dn1;
if (z__[np - 4] > z__[np - 2]) { if (z__[np - 4] > z__[np - 2]) {
return 0; return 0;
} }
a2 = z__[np - 4] / z__[np - 2]; a2 = z__[np - 4] / z__[np - 2];
if (z__[nn - 9] > z__[nn - 11]) { if (z__[nn - 9] > z__[nn - 11]) {
return 0; return 0;
} }
b2 = z__[nn - 9] / z__[nn - 11]; b2 = z__[nn - 9] / z__[nn - 11];
np = nn - 13; np = nn - 13;
} }
/* Approximate contribution to norm squared from I < NN-1. */ /* Approximate contribution to norm squared from I < NN-1. */
a2 += b2; a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp; i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = np; i4 >= i__1; i4 += -4) { for (i4 = np; i4 >= i__1; i4 += -4) {
if (b2 == 0.) { if (b2 == 0.) {
goto L20; goto L20;
} }
b1 = b2; b1 = b2;
if (z__[i4] > z__[i4 - 2]) { if (z__[i4] > z__[i4 - 2]) {
return 0; return 0;
} }
b2 *= z__[i4] / z__[i4 - 2]; b2 *= z__[i4] / z__[i4 - 2];
a2 += b2; a2 += b2;
if (max(b2,b1) * 100. < a2 || .563 < a2) { if (max(b2,b1) * 100. < a2 || .563 < a2) {
goto L20; goto L20;
} }
/* L10: */ /* L10: */
} }
L20: L20:
a2 *= 1.05; a2 *= 1.05;
/* Rayleigh quotient residual bound. */ /* Rayleigh quotient residual bound. */
if (a2 < .563) { if (a2 < .563) {
s = gam * (1. - sqrt(a2)) / (a2 + 1.); s = gam * (1. - sqrt(a2)) / (a2 + 1.);
} }
} }
} else if (*dmin__ == *dn2) { } else if (*dmin__ == *dn2) {
/* Case 5. */ /* Case 5. */
*ttype = -5; *ttype = -5;
s = *dmin__ * .25; s = *dmin__ * .25;
/* Compute contribution to norm squared from I > NN-2. */ /* Compute contribution to norm squared from I > NN-2. */
np = nn - (*pp << 1); np = nn - (*pp << 1);
b1 = z__[np - 2]; b1 = z__[np - 2];
b2 = z__[np - 6]; b2 = z__[np - 6];
gam = *dn2; gam = *dn2;
if (z__[np - 8] > b2 || z__[np - 4] > b1) { if (z__[np - 8] > b2 || z__[np - 4] > b1) {
return 0; return 0;
} }
a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.);
/* Approximate contribution to norm squared from I < NN-2. */ /* Approximate contribution to norm squared from I < NN-2. */
if (*n0 - *i0 > 2) { if (*n0 - *i0 > 2) {
b2 = z__[nn - 13] / z__[nn - 15]; b2 = z__[nn - 13] / z__[nn - 15];
a2 += b2; a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp; i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = nn - 17; i4 >= i__1; i4 += -4) { for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
if (b2 == 0.) { if (b2 == 0.) {
goto L40; goto L40;
} }
b1 = b2; b1 = b2;
if (z__[i4] > z__[i4 - 2]) { if (z__[i4] > z__[i4 - 2]) {
return 0; return 0;
} }
b2 *= z__[i4] / z__[i4 - 2]; b2 *= z__[i4] / z__[i4 - 2];
a2 += b2; a2 += b2;
if (max(b2,b1) * 100. < a2 || .563 < a2) { if (max(b2,b1) * 100. < a2 || .563 < a2) {
goto L40; goto L40;
} }
/* L30: */ /* L30: */
} }
L40: L40:
a2 *= 1.05; a2 *= 1.05;
} }
if (a2 < .563) { if (a2 < .563) {
s = gam * (1. - sqrt(a2)) / (a2 + 1.); s = gam * (1. - sqrt(a2)) / (a2 + 1.);
} }
} else { } else {
/* Case 6, no information to guide us. */ /* Case 6, no information to guide us. */
if (*ttype == -6) { if (*ttype == -6) {
*g += (1. - *g) * .333; *g += (1. - *g) * .333;
} else if (*ttype == -18) { } else if (*ttype == -18) {
*g = .083250000000000005; *g = .083250000000000005;
} else { } else {
*g = .25; *g = .25;
} }
s = *g * *dmin__; s = *g * *dmin__;
*ttype = -6; *ttype = -6;
} }
} else if (*n0in == *n0 + 1) { } else if (*n0in == *n0 + 1) {
/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ /* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
if (*dmin1 == *dn1 && *dmin2 == *dn2) { if (*dmin1 == *dn1 && *dmin2 == *dn2) {
/* Cases 7 and 8. */ /* Cases 7 and 8. */
*ttype = -7; *ttype = -7;
s = *dmin1 * .333; s = *dmin1 * .333;
if (z__[nn - 5] > z__[nn - 7]) { if (z__[nn - 5] > z__[nn - 7]) {
return 0; return 0;
} }
b1 = z__[nn - 5] / z__[nn - 7]; b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1; b2 = b1;
if (b2 == 0.) { if (b2 == 0.) {
goto L60; goto L60;
} }
i__1 = (*i0 << 2) - 1 + *pp; i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
a2 = b1; a2 = b1;
if (z__[i4] > z__[i4 - 2]) { if (z__[i4] > z__[i4 - 2]) {
return 0; return 0;
} }
b1 *= z__[i4] / z__[i4 - 2]; b1 *= z__[i4] / z__[i4 - 2];
b2 += b1; b2 += b1;
if (max(b1,a2) * 100. < b2) { if (max(b1,a2) * 100. < b2) {
goto L60; goto L60;
} }
/* L50: */ /* L50: */
} }
L60: L60:
b2 = sqrt(b2 * 1.05); b2 = sqrt(b2 * 1.05);
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = b2; d__1 = b2;
a2 = *dmin1 / (d__1 * d__1 + 1.); a2 = *dmin1 / (d__1 * d__1 + 1.);
gap2 = *dmin2 * .5 - a2; gap2 = *dmin2 * .5 - a2;
if (gap2 > 0. && gap2 > b2 * a2) { if (gap2 > 0. && gap2 > b2 * a2) {
/* Computing MAX */ /* Computing MAX */
d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
s = max(d__1,d__2); s = max(d__1,d__2);
} else { } else {
/* Computing MAX */ /* Computing MAX */
d__1 = s, d__2 = a2 * (1. - b2 * 1.01); d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
s = max(d__1,d__2); s = max(d__1,d__2);
*ttype = -8; *ttype = -8;
} }
} else { } else {
/* Case 9. */ /* Case 9. */
s = *dmin1 * .25; s = *dmin1 * .25;
if (*dmin1 == *dn1) { if (*dmin1 == *dn1) {
s = *dmin1 * .5; s = *dmin1 * .5;
} }
*ttype = -9; *ttype = -9;
} }
} else if (*n0in == *n0 + 2) { } else if (*n0in == *n0 + 2) {
@ -438,55 +438,55 @@ L60:
/* Cases 10 and 11. */ /* Cases 10 and 11. */
if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) {
*ttype = -10; *ttype = -10;
s = *dmin2 * .333; s = *dmin2 * .333;
if (z__[nn - 5] > z__[nn - 7]) { if (z__[nn - 5] > z__[nn - 7]) {
return 0; return 0;
} }
b1 = z__[nn - 5] / z__[nn - 7]; b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1; b2 = b1;
if (b2 == 0.) { if (b2 == 0.) {
goto L80; goto L80;
} }
i__1 = (*i0 << 2) - 1 + *pp; i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
if (z__[i4] > z__[i4 - 2]) { if (z__[i4] > z__[i4 - 2]) {
return 0; return 0;
} }
b1 *= z__[i4] / z__[i4 - 2]; b1 *= z__[i4] / z__[i4 - 2];
b2 += b1; b2 += b1;
if (b1 * 100. < b2) { if (b1 * 100. < b2) {
goto L80; goto L80;
} }
/* L70: */ /* L70: */
} }
L80: L80:
b2 = sqrt(b2 * 1.05); b2 = sqrt(b2 * 1.05);
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = b2; d__1 = b2;
a2 = *dmin2 / (d__1 * d__1 + 1.); a2 = *dmin2 / (d__1 * d__1 + 1.);
gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
nn - 9]) - a2; nn - 9]) - a2;
if (gap2 > 0. && gap2 > b2 * a2) { if (gap2 > 0. && gap2 > b2 * a2) {
/* Computing MAX */ /* Computing MAX */
d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
s = max(d__1,d__2); s = max(d__1,d__2);
} else { } else {
/* Computing MAX */ /* Computing MAX */
d__1 = s, d__2 = a2 * (1. - b2 * 1.01); d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
s = max(d__1,d__2); s = max(d__1,d__2);
} }
} else { } else {
s = *dmin2 * .25; s = *dmin2 * .25;
*ttype = -11; *ttype = -11;
} }
} else if (*n0in > *n0 + 2) { } else if (*n0in > *n0 + 2) {
/* Case 12, more than two eigenvalues deflated. No information. */ /* Case 12, more than two eigenvalues deflated. No information. */
s = 0.; s = 0.;
*ttype = -12; *ttype = -12;
} }
*tau = s; *tau = s;
@ -497,5 +497,5 @@ L80:
} /* dlasq4_ */ } /* dlasq4_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

444
lib/linalg/dlasq5.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasq5.f -- translated by f2c (version 20200916). /* fortran/dlasq5.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -159,10 +159,10 @@ f"> */
/* > \ingroup auxOTHERcomputational */ /* > \ingroup auxOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__, /* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *tau, doublereal *sigma, doublereal *dmin__, integer *pp, doublereal *tau, doublereal *sigma, doublereal *dmin__,
doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal * doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *
dnm1, doublereal *dnm2, logical *ieee, doublereal *eps) dnm1, doublereal *dnm2, logical *ieee, doublereal *eps)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -198,273 +198,273 @@ f"> */
/* Function Body */ /* Function Body */
if (*n0 - *i0 - 1 <= 0) { if (*n0 - *i0 - 1 <= 0) {
return 0; return 0;
} }
dthresh = *eps * (*sigma + *tau); dthresh = *eps * (*sigma + *tau);
if (*tau < dthresh * .5) { if (*tau < dthresh * .5) {
*tau = 0.; *tau = 0.;
} }
if (*tau != 0.) { if (*tau != 0.) {
j4 = (*i0 << 2) + *pp - 3; j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4]; emin = z__[j4 + 4];
d__ = z__[j4] - *tau; d__ = z__[j4] - *tau;
*dmin__ = d__; *dmin__ = d__;
*dmin1 = -z__[j4]; *dmin1 = -z__[j4];
if (*ieee) { if (*ieee) {
/* Code for IEEE arithmetic. */ /* Code for IEEE arithmetic. */
if (*pp == 0) { if (*pp == 0) {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1]; z__[j4 - 2] = d__ + z__[j4 - 1];
temp = z__[j4 + 1] / z__[j4 - 2]; temp = z__[j4 + 1] / z__[j4 - 2];
d__ = d__ * temp - *tau; d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
z__[j4] = z__[j4 - 1] * temp; z__[j4] = z__[j4 - 1] * temp;
/* Computing MIN */ /* Computing MIN */
d__1 = z__[j4]; d__1 = z__[j4];
emin = min(d__1,emin); emin = min(d__1,emin);
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4]; z__[j4 - 3] = d__ + z__[j4];
temp = z__[j4 + 2] / z__[j4 - 3]; temp = z__[j4 + 2] / z__[j4 - 3];
d__ = d__ * temp - *tau; d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
z__[j4 - 1] = z__[j4] * temp; z__[j4 - 1] = z__[j4] * temp;
/* Computing MIN */ /* Computing MIN */
d__1 = z__[j4 - 1]; d__1 = z__[j4 - 1];
emin = min(d__1,emin); emin = min(d__1,emin);
/* L20: */ /* L20: */
} }
} }
/* Unroll last two steps. */ /* Unroll last two steps. */
*dnm2 = d__; *dnm2 = d__;
*dmin2 = *dmin__; *dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp; j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2]; z__[j4 - 2] = *dnm2 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dnm1); *dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__; *dmin1 = *dmin__;
j4 += 4; j4 += 4;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2]; z__[j4 - 2] = *dnm1 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dn); *dmin__ = min(*dmin__,*dn);
} else { } else {
/* Code for non IEEE arithmetic. */ /* Code for non IEEE arithmetic. */
if (*pp == 0) { if (*pp == 0) {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1]; z__[j4 - 2] = d__ + z__[j4 - 1];
if (d__ < 0.) { if (d__ < 0.) {
return 0; return 0;
} else { } else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[j4]; d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4]; z__[j4 - 3] = d__ + z__[j4];
if (d__ < 0.) { if (d__ < 0.) {
return 0; return 0;
} else { } else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1]; d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L40: */ /* L40: */
} }
} }
/* Unroll last two steps. */ /* Unroll last two steps. */
*dnm2 = d__; *dnm2 = d__;
*dmin2 = *dmin__; *dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp; j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2]; z__[j4 - 2] = *dnm2 + z__[j4p2];
if (*dnm2 < 0.) { if (*dnm2 < 0.) {
return 0; return 0;
} else { } else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
} }
*dmin__ = min(*dmin__,*dnm1); *dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__; *dmin1 = *dmin__;
j4 += 4; j4 += 4;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2]; z__[j4 - 2] = *dnm1 + z__[j4p2];
if (*dnm1 < 0.) { if (*dnm1 < 0.) {
return 0; return 0;
} else { } else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
} }
*dmin__ = min(*dmin__,*dn); *dmin__ = min(*dmin__,*dn);
} }
} else { } else {
/* This is the version that sets d's to zero if they are small enough */ /* This is the version that sets d's to zero if they are small enough */
j4 = (*i0 << 2) + *pp - 3; j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4]; emin = z__[j4 + 4];
d__ = z__[j4] - *tau; d__ = z__[j4] - *tau;
*dmin__ = d__; *dmin__ = d__;
*dmin1 = -z__[j4]; *dmin1 = -z__[j4];
if (*ieee) { if (*ieee) {
/* Code for IEEE arithmetic. */ /* Code for IEEE arithmetic. */
if (*pp == 0) { if (*pp == 0) {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1]; z__[j4 - 2] = d__ + z__[j4 - 1];
temp = z__[j4 + 1] / z__[j4 - 2]; temp = z__[j4 + 1] / z__[j4 - 2];
d__ = d__ * temp - *tau; d__ = d__ * temp - *tau;
if (d__ < dthresh) { if (d__ < dthresh) {
d__ = 0.; d__ = 0.;
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
z__[j4] = z__[j4 - 1] * temp; z__[j4] = z__[j4 - 1] * temp;
/* Computing MIN */ /* Computing MIN */
d__1 = z__[j4]; d__1 = z__[j4];
emin = min(d__1,emin); emin = min(d__1,emin);
/* L50: */ /* L50: */
} }
} else { } else {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4]; z__[j4 - 3] = d__ + z__[j4];
temp = z__[j4 + 2] / z__[j4 - 3]; temp = z__[j4 + 2] / z__[j4 - 3];
d__ = d__ * temp - *tau; d__ = d__ * temp - *tau;
if (d__ < dthresh) { if (d__ < dthresh) {
d__ = 0.; d__ = 0.;
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
z__[j4 - 1] = z__[j4] * temp; z__[j4 - 1] = z__[j4] * temp;
/* Computing MIN */ /* Computing MIN */
d__1 = z__[j4 - 1]; d__1 = z__[j4 - 1];
emin = min(d__1,emin); emin = min(d__1,emin);
/* L60: */ /* L60: */
} }
} }
/* Unroll last two steps. */ /* Unroll last two steps. */
*dnm2 = d__; *dnm2 = d__;
*dmin2 = *dmin__; *dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp; j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2]; z__[j4 - 2] = *dnm2 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dnm1); *dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__; *dmin1 = *dmin__;
j4 += 4; j4 += 4;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2]; z__[j4 - 2] = *dnm1 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dn); *dmin__ = min(*dmin__,*dn);
} else { } else {
/* Code for non IEEE arithmetic. */ /* Code for non IEEE arithmetic. */
if (*pp == 0) { if (*pp == 0) {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1]; z__[j4 - 2] = d__ + z__[j4 - 1];
if (d__ < 0.) { if (d__ < 0.) {
return 0; return 0;
} else { } else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
} }
if (d__ < dthresh) { if (d__ < dthresh) {
d__ = 0.; d__ = 0.;
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[j4]; d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L70: */ /* L70: */
} }
} else { } else {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4]; z__[j4 - 3] = d__ + z__[j4];
if (d__ < 0.) { if (d__ < 0.) {
return 0; return 0;
} else { } else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
} }
if (d__ < dthresh) { if (d__ < dthresh) {
d__ = 0.; d__ = 0.;
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1]; d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L80: */ /* L80: */
} }
} }
/* Unroll last two steps. */ /* Unroll last two steps. */
*dnm2 = d__; *dnm2 = d__;
*dmin2 = *dmin__; *dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp; j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2]; z__[j4 - 2] = *dnm2 + z__[j4p2];
if (*dnm2 < 0.) { if (*dnm2 < 0.) {
return 0; return 0;
} else { } else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
} }
*dmin__ = min(*dmin__,*dnm1); *dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__; *dmin1 = *dmin__;
j4 += 4; j4 += 4;
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2]; z__[j4 - 2] = *dnm1 + z__[j4p2];
if (*dnm1 < 0.) { if (*dnm1 < 0.) {
return 0; return 0;
} else { } else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
} }
*dmin__ = min(*dmin__,*dn); *dmin__ = min(*dmin__,*dn);
} }
} }
z__[j4 + 2] = *dn; z__[j4 + 2] = *dn;
@ -476,5 +476,5 @@ f"> */
} /* dlasq5_ */ } /* dlasq5_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

152
lib/linalg/dlasq6.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasq6.f -- translated by f2c (version 20200916). /* fortran/dlasq6.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -134,9 +134,9 @@ f"> */
/* > \ingroup auxOTHERcomputational */ /* > \ingroup auxOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__, /* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dnm1, doublereal *dnm2) doublereal *dn, doublereal *dnm1, doublereal *dnm2)
{ {
/* System generated locals */ /* System generated locals */
integer i__1; integer i__1;
@ -176,7 +176,7 @@ f"> */
/* Function Body */ /* Function Body */
if (*n0 - *i0 - 1 <= 0) { if (*n0 - *i0 - 1 <= 0) {
return 0; return 0;
} }
safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); safmin = dlamch_((char *)"Safe minimum", (ftnlen)12);
@ -186,53 +186,53 @@ f"> */
*dmin__ = d__; *dmin__ = d__;
if (*pp == 0) { if (*pp == 0) {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1]; z__[j4 - 2] = d__ + z__[j4 - 1];
if (z__[j4 - 2] == 0.) { if (z__[j4 - 2] == 0.) {
z__[j4] = 0.; z__[j4] = 0.;
d__ = z__[j4 + 1]; d__ = z__[j4 + 1];
*dmin__ = d__; *dmin__ = d__;
emin = 0.; emin = 0.;
} else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
- 2] < z__[j4 + 1]) { - 2] < z__[j4 + 1]) {
temp = z__[j4 + 1] / z__[j4 - 2]; temp = z__[j4 + 1] / z__[j4 - 2];
z__[j4] = z__[j4 - 1] * temp; z__[j4] = z__[j4 - 1] * temp;
d__ *= temp; d__ *= temp;
} else { } else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[j4]; d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n0 - 3 << 2; i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4]; z__[j4 - 3] = d__ + z__[j4];
if (z__[j4 - 3] == 0.) { if (z__[j4 - 3] == 0.) {
z__[j4 - 1] = 0.; z__[j4 - 1] = 0.;
d__ = z__[j4 + 2]; d__ = z__[j4 + 2];
*dmin__ = d__; *dmin__ = d__;
emin = 0.; emin = 0.;
} else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
- 3] < z__[j4 + 2]) { - 3] < z__[j4 + 2]) {
temp = z__[j4 + 2] / z__[j4 - 3]; temp = z__[j4 + 2] / z__[j4 - 3];
z__[j4 - 1] = z__[j4] * temp; z__[j4 - 1] = z__[j4] * temp;
d__ *= temp; d__ *= temp;
} else { } else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
} }
*dmin__ = min(*dmin__,d__); *dmin__ = min(*dmin__,d__);
/* Computing MIN */ /* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1]; d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2); emin = min(d__1,d__2);
/* L20: */ /* L20: */
} }
} }
/* Unroll last two steps. */ /* Unroll last two steps. */
@ -243,18 +243,18 @@ f"> */
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2]; z__[j4 - 2] = *dnm2 + z__[j4p2];
if (z__[j4 - 2] == 0.) { if (z__[j4 - 2] == 0.) {
z__[j4] = 0.; z__[j4] = 0.;
*dnm1 = z__[j4p2 + 2]; *dnm1 = z__[j4p2 + 2];
*dmin__ = *dnm1; *dmin__ = *dnm1;
emin = 0.; emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) { z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2]; temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp; z__[j4] = z__[j4p2] * temp;
*dnm1 = *dnm2 * temp; *dnm1 = *dnm2 * temp;
} else { } else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
} }
*dmin__ = min(*dmin__,*dnm1); *dmin__ = min(*dmin__,*dnm1);
@ -263,18 +263,18 @@ f"> */
j4p2 = j4 + (*pp << 1) - 1; j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2]; z__[j4 - 2] = *dnm1 + z__[j4p2];
if (z__[j4 - 2] == 0.) { if (z__[j4 - 2] == 0.) {
z__[j4] = 0.; z__[j4] = 0.;
*dn = z__[j4p2 + 2]; *dn = z__[j4p2 + 2];
*dmin__ = *dn; *dmin__ = *dn;
emin = 0.; emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) { z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2]; temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp; z__[j4] = z__[j4p2] * temp;
*dn = *dnm1 * temp; *dn = *dnm1 * temp;
} else { } else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
} }
*dmin__ = min(*dmin__,*dn); *dmin__ = min(*dmin__,*dn);
@ -287,5 +287,5 @@ f"> */
} /* dlasq6_ */ } /* dlasq6_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

450
lib/linalg/dlasr.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasr.f -- translated by f2c (version 20200916). /* fortran/dlasr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -216,8 +216,8 @@ extern "C" {
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m, /* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m,
integer *n, doublereal *c__, doublereal *s, doublereal *a, integer * integer *n, doublereal *c__, doublereal *s, doublereal *a, integer *
lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len) lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -265,264 +265,264 @@ extern "C" {
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", ( if (! (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", (
ftnlen)1, (ftnlen)1))) { ftnlen)1, (ftnlen)1))) {
info = 1; info = 1;
} else if (! (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || lsame_(pivot, } else if (! (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || lsame_(pivot,
(char *)"T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, (char *)"B", (ftnlen)1, ( (char *)"T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, (char *)"B", (ftnlen)1, (
ftnlen)1))) { ftnlen)1))) {
info = 2; info = 2;
} else if (! (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(direct, } else if (! (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(direct,
(char *)"B", (ftnlen)1, (ftnlen)1))) { (char *)"B", (ftnlen)1, (ftnlen)1))) {
info = 3; info = 3;
} else if (*m < 0) { } else if (*m < 0) {
info = 4; info = 4;
} else if (*n < 0) { } else if (*n < 0) {
info = 5; info = 5;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
info = 9; info = 9;
} }
if (info != 0) { if (info != 0) {
xerbla_((char *)"DLASR ", &info, (ftnlen)6); xerbla_((char *)"DLASR ", &info, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
return 0; return 0;
} }
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Form P * A */ /* Form P * A */
if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *m - 1; i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + 1 + i__ * a_dim1]; temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1]; a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1]; + i__ * a_dim1];
/* L10: */ /* L10: */
} }
} }
/* L20: */ /* L20: */
} }
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *m - 1; j >= 1; --j) { for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + 1 + i__ * a_dim1]; temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1]; a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1]; + i__ * a_dim1];
/* L30: */ /* L30: */
} }
} }
/* L40: */ /* L40: */
} }
} }
} else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *m; i__1 = *m;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1]; ctemp = c__[j - 1];
stemp = s[j - 1]; stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1]; temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1]; i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1]; i__ * a_dim1 + 1];
/* L50: */ /* L50: */
} }
} }
/* L60: */ /* L60: */
} }
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *m; j >= 2; --j) { for (j = *m; j >= 2; --j) {
ctemp = c__[j - 1]; ctemp = c__[j - 1];
stemp = s[j - 1]; stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1]; temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1]; i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1]; i__ * a_dim1 + 1];
/* L70: */ /* L70: */
} }
} }
/* L80: */ /* L80: */
} }
} }
} else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *m - 1; i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1]; temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp; + ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp; a_dim1] - stemp * temp;
/* L90: */ /* L90: */
} }
} }
/* L100: */ /* L100: */
} }
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *m - 1; j >= 1; --j) { for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1]; temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp; + ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp; a_dim1] - stemp * temp;
/* L110: */ /* L110: */
} }
} }
/* L120: */ /* L120: */
} }
} }
} }
} else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
/* Form A * P**T */ /* Form A * P**T */
if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *n - 1; i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + (j + 1) * a_dim1]; temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1]; a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1]; i__ + j * a_dim1];
/* L130: */ /* L130: */
} }
} }
/* L140: */ /* L140: */
} }
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *n - 1; j >= 1; --j) { for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__1 = *m; i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + (j + 1) * a_dim1]; temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1]; a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1]; i__ + j * a_dim1];
/* L150: */ /* L150: */
} }
} }
/* L160: */ /* L160: */
} }
} }
} else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *n; i__1 = *n;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1]; ctemp = c__[j - 1];
stemp = s[j - 1]; stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1]; temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1]; i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1]; a_dim1];
/* L170: */ /* L170: */
} }
} }
/* L180: */ /* L180: */
} }
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *n; j >= 2; --j) { for (j = *n; j >= 2; --j) {
ctemp = c__[j - 1]; ctemp = c__[j - 1];
stemp = s[j - 1]; stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__1 = *m; i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1]; temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1]; i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1]; a_dim1];
/* L190: */ /* L190: */
} }
} }
/* L200: */ /* L200: */
} }
} }
} else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *n - 1; i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__2 = *m; i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1]; temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp; + ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp; a_dim1] - stemp * temp;
/* L210: */ /* L210: */
} }
} }
/* L220: */ /* L220: */
} }
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *n - 1; j >= 1; --j) { for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j]; ctemp = c__[j];
stemp = s[j]; stemp = s[j];
if (ctemp != 1. || stemp != 0.) { if (ctemp != 1. || stemp != 0.) {
i__1 = *m; i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1]; temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp; + ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp; a_dim1] - stemp * temp;
/* L230: */ /* L230: */
} }
} }
/* L240: */ /* L240: */
} }
} }
} }
} }
return 0; return 0;
@ -532,5 +532,5 @@ extern "C" {
} /* dlasr_ */ } /* dlasr_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

272
lib/linalg/dlasrt.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasrt.f -- translated by f2c (version 20200916). /* fortran/dlasrt.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -105,7 +105,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer * /* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer *
info, ftnlen id_len) info, ftnlen id_len)
{ {
/* System generated locals */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
@ -117,7 +117,7 @@ f"> */
doublereal tmp; doublereal tmp;
integer endd; integer endd;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer stack[64] /* was [2][32] */; integer stack[64] /* was [2][32] */;
doublereal dmnmx; doublereal dmnmx;
integer start; integer start;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
@ -156,25 +156,25 @@ f"> */
*info = 0; *info = 0;
dir = -1; dir = -1;
if (lsame_(id, (char *)"D", (ftnlen)1, (ftnlen)1)) { if (lsame_(id, (char *)"D", (ftnlen)1, (ftnlen)1)) {
dir = 0; dir = 0;
} else if (lsame_(id, (char *)"I", (ftnlen)1, (ftnlen)1)) { } else if (lsame_(id, (char *)"I", (ftnlen)1, (ftnlen)1)) {
dir = 1; dir = 1;
} }
if (dir == -1) { if (dir == -1) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DLASRT", &i__1, (ftnlen)6); xerbla_((char *)"DLASRT", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n <= 1) { if (*n <= 1) {
return 0; return 0;
} }
stkpnt = 1; stkpnt = 1;
@ -188,49 +188,49 @@ L10:
/* Do Insertion sort on D( START:ENDD ) */ /* Do Insertion sort on D( START:ENDD ) */
if (dir == 0) { if (dir == 0) {
/* Sort into decreasing order */ /* Sort into decreasing order */
i__1 = endd; i__1 = endd;
for (i__ = start + 1; i__ <= i__1; ++i__) { for (i__ = start + 1; i__ <= i__1; ++i__) {
i__2 = start + 1; i__2 = start + 1;
for (j = i__; j >= i__2; --j) { for (j = i__; j >= i__2; --j) {
if (d__[j] > d__[j - 1]) { if (d__[j] > d__[j - 1]) {
dmnmx = d__[j]; dmnmx = d__[j];
d__[j] = d__[j - 1]; d__[j] = d__[j - 1];
d__[j - 1] = dmnmx; d__[j - 1] = dmnmx;
} else { } else {
goto L30; goto L30;
} }
/* L20: */ /* L20: */
} }
L30: L30:
; ;
} }
} else { } else {
/* Sort into increasing order */ /* Sort into increasing order */
i__1 = endd; i__1 = endd;
for (i__ = start + 1; i__ <= i__1; ++i__) { for (i__ = start + 1; i__ <= i__1; ++i__) {
i__2 = start + 1; i__2 = start + 1;
for (j = i__; j >= i__2; --j) { for (j = i__; j >= i__2; --j) {
if (d__[j] < d__[j - 1]) { if (d__[j] < d__[j - 1]) {
dmnmx = d__[j]; dmnmx = d__[j];
d__[j] = d__[j - 1]; d__[j] = d__[j - 1];
d__[j - 1] = dmnmx; d__[j - 1] = dmnmx;
} else { } else {
goto L50; goto L50;
} }
/* L40: */ /* L40: */
} }
L50: L50:
; ;
} }
} }
} else if (endd - start > 20) { } else if (endd - start > 20) {
@ -238,108 +238,108 @@ L50:
/* Choose partition entry as median of 3 */ /* Choose partition entry as median of 3 */
d1 = d__[start]; d1 = d__[start];
d2 = d__[endd]; d2 = d__[endd];
i__ = (start + endd) / 2; i__ = (start + endd) / 2;
d3 = d__[i__]; d3 = d__[i__];
if (d1 < d2) { if (d1 < d2) {
if (d3 < d1) { if (d3 < d1) {
dmnmx = d1; dmnmx = d1;
} else if (d3 < d2) { } else if (d3 < d2) {
dmnmx = d3; dmnmx = d3;
} else { } else {
dmnmx = d2; dmnmx = d2;
} }
} else { } else {
if (d3 < d2) { if (d3 < d2) {
dmnmx = d2; dmnmx = d2;
} else if (d3 < d1) { } else if (d3 < d1) {
dmnmx = d3; dmnmx = d3;
} else { } else {
dmnmx = d1; dmnmx = d1;
} }
} }
if (dir == 0) { if (dir == 0) {
/* Sort into decreasing order */ /* Sort into decreasing order */
i__ = start - 1; i__ = start - 1;
j = endd + 1; j = endd + 1;
L60: L60:
L70: L70:
--j; --j;
if (d__[j] < dmnmx) { if (d__[j] < dmnmx) {
goto L70; goto L70;
} }
L80: L80:
++i__; ++i__;
if (d__[i__] > dmnmx) { if (d__[i__] > dmnmx) {
goto L80; goto L80;
} }
if (i__ < j) { if (i__ < j) {
tmp = d__[i__]; tmp = d__[i__];
d__[i__] = d__[j]; d__[i__] = d__[j];
d__[j] = tmp; d__[j] = tmp;
goto L60; goto L60;
} }
if (j - start > endd - j - 1) { if (j - start > endd - j - 1) {
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j; stack[(stkpnt << 1) - 1] = j;
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd; stack[(stkpnt << 1) - 1] = endd;
} else { } else {
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd; stack[(stkpnt << 1) - 1] = endd;
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j; stack[(stkpnt << 1) - 1] = j;
} }
} else { } else {
/* Sort into increasing order */ /* Sort into increasing order */
i__ = start - 1; i__ = start - 1;
j = endd + 1; j = endd + 1;
L90: L90:
L100: L100:
--j; --j;
if (d__[j] > dmnmx) { if (d__[j] > dmnmx) {
goto L100; goto L100;
} }
L110: L110:
++i__; ++i__;
if (d__[i__] < dmnmx) { if (d__[i__] < dmnmx) {
goto L110; goto L110;
} }
if (i__ < j) { if (i__ < j) {
tmp = d__[i__]; tmp = d__[i__];
d__[i__] = d__[j]; d__[i__] = d__[j];
d__[j] = tmp; d__[j] = tmp;
goto L90; goto L90;
} }
if (j - start > endd - j - 1) { if (j - start > endd - j - 1) {
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j; stack[(stkpnt << 1) - 1] = j;
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd; stack[(stkpnt << 1) - 1] = endd;
} else { } else {
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd; stack[(stkpnt << 1) - 1] = endd;
++stkpnt; ++stkpnt;
stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j; stack[(stkpnt << 1) - 1] = j;
} }
} }
} }
if (stkpnt > 0) { if (stkpnt > 0) {
goto L10; goto L10;
} }
return 0; return 0;
@ -348,5 +348,5 @@ L110:
} /* dlasrt_ */ } /* dlasrt_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

50
lib/linalg/dlassq.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlassq.f -- translated by f2c (version 20200916). /* fortran/dlassq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -121,8 +121,8 @@ f"> */
/* > \ingroup OTHERauxiliary */ /* > \ingroup OTHERauxiliary */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx, /* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx,
doublereal *scale, doublereal *sumsq) doublereal *scale, doublereal *sumsq)
{ {
/* System generated locals */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
@ -161,24 +161,24 @@ f"> */
/* Function Body */ /* Function Body */
if (*n > 0) { if (*n > 0) {
i__1 = (*n - 1) * *incx + 1; i__1 = (*n - 1) * *incx + 1;
i__2 = *incx; i__2 = *incx;
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
absxi = (d__1 = x[ix], abs(d__1)); absxi = (d__1 = x[ix], abs(d__1));
if (absxi > 0. || disnan_(&absxi)) { if (absxi > 0. || disnan_(&absxi)) {
if (*scale < absxi) { if (*scale < absxi) {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = *scale / absxi; d__1 = *scale / absxi;
*sumsq = *sumsq * (d__1 * d__1) + 1; *sumsq = *sumsq * (d__1 * d__1) + 1;
*scale = absxi; *scale = absxi;
} else { } else {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = absxi / *scale; d__1 = absxi / *scale;
*sumsq += d__1 * d__1; *sumsq += d__1 * d__1;
} }
} }
/* L10: */ /* L10: */
} }
} }
return 0; return 0;
@ -187,5 +187,5 @@ f"> */
} /* dlassq_ */ } /* dlassq_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

178
lib/linalg/dlasv2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlasv2.f -- translated by f2c (version 20200916). /* fortran/dlasv2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -159,9 +159,9 @@ f"> */
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, /* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__,
doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal * doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *
csr, doublereal *snl, doublereal *csl) csr, doublereal *snl, doublereal *csl)
{ {
/* System generated locals */ /* System generated locals */
doublereal d__1; doublereal d__1;
@ -170,8 +170,8 @@ f"> */
double sqrt(doublereal), d_sign(doublereal *, doublereal *); double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */ /* Local variables */
doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt,
crt, slt, srt; crt, slt, srt;
integer pmax; integer pmax;
doublereal temp; doublereal temp;
logical swap; logical swap;
@ -212,13 +212,13 @@ f"> */
pmax = 1; pmax = 1;
swap = ha > fa; swap = ha > fa;
if (swap) { if (swap) {
pmax = 3; pmax = 3;
temp = ft; temp = ft;
ft = ht; ft = ht;
ht = temp; ht = temp;
temp = fa; temp = fa;
fa = ha; fa = ha;
ha = temp; ha = temp;
/* Now FA .ge. HA */ /* Now FA .ge. HA */
@ -229,118 +229,118 @@ f"> */
/* Diagonal matrix */ /* Diagonal matrix */
*ssmin = ha; *ssmin = ha;
*ssmax = fa; *ssmax = fa;
clt = 1.; clt = 1.;
crt = 1.; crt = 1.;
slt = 0.; slt = 0.;
srt = 0.; srt = 0.;
} else { } else {
gasmal = TRUE_; gasmal = TRUE_;
if (ga > fa) { if (ga > fa) {
pmax = 2; pmax = 2;
if (fa / ga < dlamch_((char *)"EPS", (ftnlen)3)) { if (fa / ga < dlamch_((char *)"EPS", (ftnlen)3)) {
/* Case of very large GA */ /* Case of very large GA */
gasmal = FALSE_; gasmal = FALSE_;
*ssmax = ga; *ssmax = ga;
if (ha > 1.) { if (ha > 1.) {
*ssmin = fa / (ga / ha); *ssmin = fa / (ga / ha);
} else { } else {
*ssmin = fa / ga * ha; *ssmin = fa / ga * ha;
} }
clt = 1.; clt = 1.;
slt = ht / gt; slt = ht / gt;
srt = 1.; srt = 1.;
crt = ft / gt; crt = ft / gt;
} }
} }
if (gasmal) { if (gasmal) {
/* Normal case */ /* Normal case */
d__ = fa - ha; d__ = fa - ha;
if (d__ == fa) { if (d__ == fa) {
/* Copes with infinite F or H */ /* Copes with infinite F or H */
l = 1.; l = 1.;
} else { } else {
l = d__ / fa; l = d__ / fa;
} }
/* Note that 0 .le. L .le. 1 */ /* Note that 0 .le. L .le. 1 */
m = gt / ft; m = gt / ft;
/* Note that abs(M) .le. 1/macheps */ /* Note that abs(M) .le. 1/macheps */
t = 2. - l; t = 2. - l;
/* Note that T .ge. 1 */ /* Note that T .ge. 1 */
mm = m * m; mm = m * m;
tt = t * t; tt = t * t;
s = sqrt(tt + mm); s = sqrt(tt + mm);
/* Note that 1 .le. S .le. 1 + 1/macheps */ /* Note that 1 .le. S .le. 1 + 1/macheps */
if (l == 0.) { if (l == 0.) {
r__ = abs(m); r__ = abs(m);
} else { } else {
r__ = sqrt(l * l + mm); r__ = sqrt(l * l + mm);
} }
/* Note that 0 .le. R .le. 1 + 1/macheps */ /* Note that 0 .le. R .le. 1 + 1/macheps */
a = (s + r__) * .5; a = (s + r__) * .5;
/* Note that 1 .le. A .le. 1 + abs(M) */ /* Note that 1 .le. A .le. 1 + abs(M) */
*ssmin = ha / a; *ssmin = ha / a;
*ssmax = fa * a; *ssmax = fa * a;
if (mm == 0.) { if (mm == 0.) {
/* Note that M is very tiny */ /* Note that M is very tiny */
if (l == 0.) { if (l == 0.) {
t = d_sign(&c_b3, &ft) * d_sign(&c_b4, &gt); t = d_sign(&c_b3, &ft) * d_sign(&c_b4, &gt);
} else { } else {
t = gt / d_sign(&d__, &ft) + m / t; t = gt / d_sign(&d__, &ft) + m / t;
} }
} else { } else {
t = (m / (s + t) + m / (r__ + l)) * (a + 1.); t = (m / (s + t) + m / (r__ + l)) * (a + 1.);
} }
l = sqrt(t * t + 4.); l = sqrt(t * t + 4.);
crt = 2. / l; crt = 2. / l;
srt = t / l; srt = t / l;
clt = (crt + srt * m) / a; clt = (crt + srt * m) / a;
slt = ht / ft * srt / a; slt = ht / ft * srt / a;
} }
} }
if (swap) { if (swap) {
*csl = srt; *csl = srt;
*snl = crt; *snl = crt;
*csr = slt; *csr = slt;
*snr = clt; *snr = clt;
} else { } else {
*csl = clt; *csl = clt;
*snl = slt; *snl = slt;
*csr = crt; *csr = crt;
*snr = srt; *snr = srt;
} }
/* Correct signs of SSMAX and SSMIN */ /* Correct signs of SSMAX and SSMIN */
if (pmax == 1) { if (pmax == 1) {
tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f); tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f);
} }
if (pmax == 2) { if (pmax == 2) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g); tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g);
} }
if (pmax == 3) { if (pmax == 3) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__); tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__);
} }
*ssmax = d_sign(ssmax, &tsign); *ssmax = d_sign(ssmax, &tsign);
d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__); d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__);
@ -352,5 +352,5 @@ f"> */
} /* dlasv2_ */ } /* dlasv2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

108
lib/linalg/dlaswp.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlaswp.f -- translated by f2c (version 20200916). /* fortran/dlaswp.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -131,8 +131,8 @@ f"> */
/* > \endverbatim */ /* > \endverbatim */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer /* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer
*k1, integer *k2, integer *ipiv, integer *incx) *k1, integer *k2, integer *ipiv, integer *incx)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4; integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
@ -168,63 +168,63 @@ f"> */
/* Function Body */ /* Function Body */
if (*incx > 0) { if (*incx > 0) {
ix0 = *k1; ix0 = *k1;
i1 = *k1; i1 = *k1;
i2 = *k2; i2 = *k2;
inc = 1; inc = 1;
} else if (*incx < 0) { } else if (*incx < 0) {
ix0 = *k1 + (*k1 - *k2) * *incx; ix0 = *k1 + (*k1 - *k2) * *incx;
i1 = *k2; i1 = *k2;
i2 = *k1; i2 = *k1;
inc = -1; inc = -1;
} else { } else {
return 0; return 0;
} }
n32 = *n / 32 << 5; n32 = *n / 32 << 5;
if (n32 != 0) { if (n32 != 0) {
i__1 = n32; i__1 = n32;
for (j = 1; j <= i__1; j += 32) { for (j = 1; j <= i__1; j += 32) {
ix = ix0; ix = ix0;
i__2 = i2; i__2 = i2;
i__3 = inc; i__3 = inc;
for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
{ {
ip = ipiv[ix]; ip = ipiv[ix];
if (ip != i__) { if (ip != i__) {
i__4 = j + 31; i__4 = j + 31;
for (k = j; k <= i__4; ++k) { for (k = j; k <= i__4; ++k) {
temp = a[i__ + k * a_dim1]; temp = a[i__ + k * a_dim1];
a[i__ + k * a_dim1] = a[ip + k * a_dim1]; a[i__ + k * a_dim1] = a[ip + k * a_dim1];
a[ip + k * a_dim1] = temp; a[ip + k * a_dim1] = temp;
/* L10: */ /* L10: */
} }
} }
ix += *incx; ix += *incx;
/* L20: */ /* L20: */
} }
/* L30: */ /* L30: */
} }
} }
if (n32 != *n) { if (n32 != *n) {
++n32; ++n32;
ix = ix0; ix = ix0;
i__1 = i2; i__1 = i2;
i__3 = inc; i__3 = inc;
for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) {
ip = ipiv[ix]; ip = ipiv[ix];
if (ip != i__) { if (ip != i__) {
i__2 = *n; i__2 = *n;
for (k = n32; k <= i__2; ++k) { for (k = n32; k <= i__2; ++k) {
temp = a[i__ + k * a_dim1]; temp = a[i__ + k * a_dim1];
a[i__ + k * a_dim1] = a[ip + k * a_dim1]; a[i__ + k * a_dim1] = a[ip + k * a_dim1];
a[ip + k * a_dim1] = temp; a[ip + k * a_dim1] = temp;
/* L40: */ /* L40: */
} }
} }
ix += *incx; ix += *incx;
/* L50: */ /* L50: */
} }
} }
return 0; return 0;
@ -234,5 +234,5 @@ f"> */
} /* dlaswp_ */ } /* dlaswp_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

270
lib/linalg/dlatrd.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dlatrd.f -- translated by f2c (version 20200916). /* fortran/dlatrd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -223,28 +223,28 @@ f"> */
/* > */ /* > */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal * /* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *e, doublereal *tau, doublereal *w, a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
integer *ldw, ftnlen uplo_len) integer *ldw, ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
/* Local variables */ /* Local variables */
integer i__, iw; integer i__, iw;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *); integer *);
doublereal alpha; doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *); integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *, extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), daxpy_(integer *, doublereal *, doublereal *, integer *, ftnlen), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), doublereal *, doublereal *, integer *, doublereal *, integer *),
dsymv_(char *, integer *, doublereal *, doublereal *, integer *, dsymv_(char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen), dlarfg_(integer *, doublereal *, doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *, doublereal *, integer *,
doublereal *); doublereal *);
/* -- LAPACK auxiliary routine -- */ /* -- LAPACK auxiliary routine -- */
@ -284,154 +284,154 @@ f"> */
/* Function Body */ /* Function Body */
if (*n <= 0) { if (*n <= 0) {
return 0; return 0;
} }
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
/* Reduce last NB columns of upper triangle */ /* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1; i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) { for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb; iw = i__ - *n + *nb;
if (i__ < *n) { if (i__ < *n) {
/* Update A(1:i,i) */ /* Update A(1:i,i) */
i__2 = *n - i__; i__2 = *n - i__;
dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *n - i__; i__2 = *n - i__;
dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
} }
if (i__ > 1) { if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */ /* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */ /* A(1:i-2,i) */
i__2 = i__ - 1; i__2 = i__ - 1;
dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 +
1], &c__1, &tau[i__ - 1]); 1], &c__1, &tau[i__ - 1]);
e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; e[i__ - 1] = a[i__ - 1 + i__ * a_dim1];
a[i__ - 1 + i__ * a_dim1] = 1.; a[i__ - 1 + i__ * a_dim1] = 1.;
/* Compute W(1:i-1,i) */ /* Compute W(1:i-1,i) */
i__2 = i__ - 1; i__2 = i__ - 1;
dsymv_((char *)"Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * dsymv_((char *)"Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], &
c__1, (ftnlen)5); c__1, (ftnlen)5);
if (i__ < *n) { if (i__ < *n) {
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen) c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen)
9); 9);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen) c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12); 12);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen) c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen)
9); 9);
i__2 = i__ - 1; i__2 = i__ - 1;
i__3 = *n - i__; i__3 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen) c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12); 12);
} }
i__2 = i__ - 1; i__2 = i__ - 1;
dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1; i__2 = i__ - 1;
alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1], alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1],
&c__1, &a[i__ * a_dim1 + 1], &c__1); &c__1, &a[i__ * a_dim1 + 1], &c__1);
i__2 = i__ - 1; i__2 = i__ - 1;
daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1); w_dim1 + 1], &c__1);
} }
/* L10: */ /* L10: */
} }
} else { } else {
/* Reduce first NB columns of lower triangle */ /* Reduce first NB columns of lower triangle */
i__1 = *nb; i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */ /* Update A(i:n,i) */
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], &
c__1, (ftnlen)12); c__1, (ftnlen)12);
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], &
c__1, (ftnlen)12); c__1, (ftnlen)12);
if (i__ < *n) { if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */ /* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */ /* A(i+2:n,i) */
i__2 = *n - i__; i__2 = *n - i__;
/* Computing MIN */ /* Computing MIN */
i__3 = i__ + 2; i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) +
i__ * a_dim1], &c__1, &tau[i__]); i__ * a_dim1], &c__1, &tau[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1]; e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.; a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute W(i+1:n,i) */ /* Compute W(i+1:n,i) */
i__2 = *n - i__; i__2 = *n - i__;
dsymv_((char *)"Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] dsymv_((char *)"Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5); i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5);
i__2 = *n - i__; i__2 = *n - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1],
ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ * w_dim1 + 1], &c__1, (ftnlen)9); i__ * w_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *n - i__; i__2 = *n - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
i__2 = *n - i__; i__2 = *n - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ * w_dim1 + 1], &c__1, (ftnlen)9); i__ * w_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *n - i__; i__2 = *n - i__;
i__3 = i__ - 1; i__3 = i__ - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
i__2 = *n - i__; i__2 = *n - i__;
dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__; i__2 = *n - i__;
alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ * alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ *
w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *n - i__; i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1); i__ + 1 + i__ * w_dim1], &c__1);
} }
/* L20: */ /* L20: */
} }
} }
return 0; return 0;
@ -441,5 +441,5 @@ f"> */
} /* dlatrd_ */ } /* dlatrd_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

760
lib/linalg/dlatrs.cpp
View File

File diff suppressed because it is too large Load Diff

56
lib/linalg/dnrm2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dnrm2.f -- translated by f2c (version 20200916). /* fortran/dnrm2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -126,35 +126,35 @@ doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
/* Function Body */ /* Function Body */
if (*n < 1 || *incx < 1) { if (*n < 1 || *incx < 1) {
norm = 0.; norm = 0.;
} else if (*n == 1) { } else if (*n == 1) {
norm = abs(x[1]); norm = abs(x[1]);
} else { } else {
scale = 0.; scale = 0.;
ssq = 1.; ssq = 1.;
/* The following loop is equivalent to this call to the LAPACK */ /* The following loop is equivalent to this call to the LAPACK */
/* auxiliary routine: */ /* auxiliary routine: */
/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ /* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */
i__1 = (*n - 1) * *incx + 1; i__1 = (*n - 1) * *incx + 1;
i__2 = *incx; i__2 = *incx;
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
if (x[ix] != 0.) { if (x[ix] != 0.) {
absxi = (d__1 = x[ix], abs(d__1)); absxi = (d__1 = x[ix], abs(d__1));
if (scale < absxi) { if (scale < absxi) {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = scale / absxi; d__1 = scale / absxi;
ssq = ssq * (d__1 * d__1) + 1.; ssq = ssq * (d__1 * d__1) + 1.;
scale = absxi; scale = absxi;
} else { } else {
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = absxi / scale; d__1 = absxi / scale;
ssq += d__1 * d__1; ssq += d__1 * d__1;
} }
} }
/* L10: */ /* L10: */
} }
norm = scale * sqrt(ssq); norm = scale * sqrt(ssq);
} }
ret_val = norm; ret_val = norm;
@ -165,5 +165,5 @@ doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
} /* dnrm2_ */ } /* dnrm2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

80
lib/linalg/dorg2l.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorg2l.f -- translated by f2c (version 20200916). /* fortran/dorg2l.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -136,7 +136,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal * /* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *info) a, integer *lda, doublereal *tau, doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -144,10 +144,10 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, j, l, ii; integer i__, j, l, ii;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *, integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -183,62 +183,62 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0 || *n > *m) { } else if (*n < 0 || *n > *m) {
*info = -2; *info = -2;
} else if (*k < 0 || *k > *n) { } else if (*k < 0 || *k > *n) {
*info = -3; *info = -3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -5; *info = -5;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORG2L", &i__1, (ftnlen)6); xerbla_((char *)"DORG2L", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n <= 0) { if (*n <= 0) {
return 0; return 0;
} }
/* Initialise columns 1:n-k to columns of the unit matrix */ /* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k; i__1 = *n - *k;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (l = 1; l <= i__2; ++l) { for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.; a[l + j * a_dim1] = 0.;
/* L10: */ /* L10: */
} }
a[*m - *n + j + j * a_dim1] = 1.; a[*m - *n + j + j * a_dim1] = 1.;
/* L20: */ /* L20: */
} }
i__1 = *k; i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
ii = *n - *k + i__; ii = *n - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */ /* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
a[*m - *n + ii + ii * a_dim1] = 1.; a[*m - *n + ii + ii * a_dim1] = 1.;
i__2 = *m - *n + ii; i__2 = *m - *n + ii;
i__3 = ii - 1; i__3 = ii - 1;
dlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & dlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
a[a_offset], lda, &work[1], (ftnlen)4); a[a_offset], lda, &work[1], (ftnlen)4);
i__2 = *m - *n + ii - 1; i__2 = *m - *n + ii - 1;
d__1 = -tau[i__]; d__1 = -tau[i__];
dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1); dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1);
a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__]; a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__];
/* Set A(m-k+i+1:m,n-k+i) to zero */ /* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m; i__2 = *m;
for (l = *m - *n + ii + 1; l <= i__2; ++l) { for (l = *m - *n + ii + 1; l <= i__2; ++l) {
a[l + ii * a_dim1] = 0.; a[l + ii * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
return 0; return 0;
@ -248,5 +248,5 @@ f"> */
} /* dorg2l_ */ } /* dorg2l_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

88
lib/linalg/dorg2r.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorg2r.f -- translated by f2c (version 20200916). /* fortran/dorg2r.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -136,7 +136,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal * /* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *info) a, integer *lda, doublereal *tau, doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -144,10 +144,10 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, j, l; integer i__, j, l;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *, integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -183,36 +183,36 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0 || *n > *m) { } else if (*n < 0 || *n > *m) {
*info = -2; *info = -2;
} else if (*k < 0 || *k > *n) { } else if (*k < 0 || *k > *n) {
*info = -3; *info = -3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -5; *info = -5;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORG2R", &i__1, (ftnlen)6); xerbla_((char *)"DORG2R", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n <= 0) { if (*n <= 0) {
return 0; return 0;
} }
/* Initialise columns k+1:n to columns of the unit matrix */ /* Initialise columns k+1:n to columns of the unit matrix */
i__1 = *n; i__1 = *n;
for (j = *k + 1; j <= i__1; ++j) { for (j = *k + 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (l = 1; l <= i__2; ++l) { for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.; a[l + j * a_dim1] = 0.;
/* L10: */ /* L10: */
} }
a[j + j * a_dim1] = 1.; a[j + j * a_dim1] = 1.;
/* L20: */ /* L20: */
} }
@ -220,28 +220,28 @@ f"> */
/* Apply H(i) to A(i:m,i:n) from the left */ /* Apply H(i) to A(i:m,i:n) from the left */
if (i__ < *n) { if (i__ < *n) {
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
i__1 = *m - i__ + 1; i__1 = *m - i__ + 1;
i__2 = *n - i__; i__2 = *n - i__;
dlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ dlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4); ftnlen)4);
} }
if (i__ < *m) { if (i__ < *m) {
i__1 = *m - i__; i__1 = *m - i__;
d__1 = -tau[i__]; d__1 = -tau[i__];
dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
} }
a[i__ + i__ * a_dim1] = 1. - tau[i__]; a[i__ + i__ * a_dim1] = 1. - tau[i__];
/* Set A(1:i-1,i) to zero */ /* Set A(1:i-1,i) to zero */
i__1 = i__ - 1; i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) { for (l = 1; l <= i__1; ++l) {
a[l + i__ * a_dim1] = 0.; a[l + i__ * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
return 0; return 0;
@ -251,5 +251,5 @@ f"> */
} /* dorg2r_ */ } /* dorg2r_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

214
lib/linalg/dorgbr.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorgbr.f -- translated by f2c (version 20200916). /* fortran/dorgbr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -177,9 +177,9 @@ f"> */
/* > \ingroup doubleGBcomputational */ /* > \ingroup doubleGBcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k, /* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k,
doublereal *a, integer *lda, doublereal *tau, doublereal *work, doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *lwork, integer *info, ftnlen vect_len) integer *lwork, integer *info, ftnlen vect_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -190,10 +190,10 @@ f"> */
integer iinfo; integer iinfo;
logical wantq; logical wantq;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dorglq_( extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dorglq_(
integer *, integer *, integer *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dorgqr_( doublereal *, doublereal *, integer *, integer *), dorgqr_(
integer *, integer *, integer *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *); doublereal *, doublereal *, integer *, integer *);
integer lwkopt; integer lwkopt;
logical lquery; logical lquery;
@ -236,67 +236,67 @@ f"> */
mn = min(*m,*n); mn = min(*m,*n);
lquery = *lwork == -1; lquery = *lwork == -1;
if (! wantq && ! lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) { if (! wantq && ! lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (*m < 0) { } else if (*m < 0) {
*info = -2; *info = -2;
} else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && ( } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
*m > *n || *m < min(*n,*k))) { *m > *n || *m < min(*n,*k))) {
*info = -3; *info = -3;
} else if (*k < 0) { } else if (*k < 0) {
*info = -4; *info = -4;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -6; *info = -6;
} else if (*lwork < max(1,mn) && ! lquery) { } else if (*lwork < max(1,mn) && ! lquery) {
*info = -9; *info = -9;
} }
if (*info == 0) { if (*info == 0) {
work[1] = 1.; work[1] = 1.;
if (wantq) { if (wantq) {
if (*m >= *k) { if (*m >= *k) {
dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1,
&iinfo); &iinfo);
} else { } else {
if (*m > 1) { if (*m > 1) {
i__1 = *m - 1; i__1 = *m - 1;
i__2 = *m - 1; i__2 = *m - 1;
i__3 = *m - 1; i__3 = *m - 1;
dorgqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & dorgqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &
work[1], &c_n1, &iinfo); work[1], &c_n1, &iinfo);
} }
} }
} else { } else {
if (*k < *n) { if (*k < *n) {
dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1,
&iinfo); &iinfo);
} else { } else {
if (*n > 1) { if (*n > 1) {
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
dorglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & dorglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &
work[1], &c_n1, &iinfo); work[1], &c_n1, &iinfo);
} }
} }
} }
lwkopt = (integer) work[1]; lwkopt = (integer) work[1];
lwkopt = max(lwkopt,mn); lwkopt = max(lwkopt,mn);
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORGBR", &i__1, (ftnlen)6); xerbla_((char *)"DORGBR", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
if (wantq) { if (wantq) {
@ -304,14 +304,14 @@ f"> */
/* Form Q, determined by a call to DGEBRD to reduce an m-by-k */ /* Form Q, determined by a call to DGEBRD to reduce an m-by-k */
/* matrix */ /* matrix */
if (*m >= *k) { if (*m >= *k) {
/* If m >= k, assume m >= n >= k */ /* If m >= k, assume m >= n >= k */
dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo); iinfo);
} else { } else {
/* If m < k, assume m = n */ /* If m < k, assume m = n */
@ -319,45 +319,45 @@ f"> */
/* column to the right, and set the first row and column of Q */ /* column to the right, and set the first row and column of Q */
/* to those of the unit matrix */ /* to those of the unit matrix */
for (j = *m; j >= 2; --j) { for (j = *m; j >= 2; --j) {
a[j * a_dim1 + 1] = 0.; a[j * a_dim1 + 1] = 0.;
i__1 = *m; i__1 = *m;
for (i__ = j + 1; i__ <= i__1; ++i__) { for (i__ = j + 1; i__ <= i__1; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
a[a_dim1 + 1] = 1.; a[a_dim1 + 1] = 1.;
i__1 = *m; i__1 = *m;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.; a[i__ + a_dim1] = 0.;
/* L30: */ /* L30: */
} }
if (*m > 1) { if (*m > 1) {
/* Form Q(2:m,2:m) */ /* Form Q(2:m,2:m) */
i__1 = *m - 1; i__1 = *m - 1;
i__2 = *m - 1; i__2 = *m - 1;
i__3 = *m - 1; i__3 = *m - 1;
dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo); 1], &work[1], lwork, &iinfo);
} }
} }
} else { } else {
/* Form P**T, determined by a call to DGEBRD to reduce a k-by-n */ /* Form P**T, determined by a call to DGEBRD to reduce a k-by-n */
/* matrix */ /* matrix */
if (*k < *n) { if (*k < *n) {
/* If k < n, assume k <= m <= n */ /* If k < n, assume k <= m <= n */
dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo); iinfo);
} else { } else {
/* If k >= n, assume m = n */ /* If k >= n, assume m = n */
@ -365,32 +365,32 @@ f"> */
/* row downward, and set the first row and column of P**T to */ /* row downward, and set the first row and column of P**T to */
/* those of the unit matrix */ /* those of the unit matrix */
a[a_dim1 + 1] = 1.; a[a_dim1 + 1] = 1.;
i__1 = *n; i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.; a[i__ + a_dim1] = 0.;
/* L40: */ /* L40: */
} }
i__1 = *n; i__1 = *n;
for (j = 2; j <= i__1; ++j) { for (j = 2; j <= i__1; ++j) {
for (i__ = j - 1; i__ >= 2; --i__) { for (i__ = j - 1; i__ >= 2; --i__) {
a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1];
/* L50: */ /* L50: */
} }
a[j * a_dim1 + 1] = 0.; a[j * a_dim1 + 1] = 0.;
/* L60: */ /* L60: */
} }
if (*n > 1) { if (*n > 1) {
/* Form P**T(2:n,2:n) */ /* Form P**T(2:n,2:n) */
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo); 1], &work[1], lwork, &iinfo);
} }
} }
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
@ -400,5 +400,5 @@ f"> */
} /* dorgbr_ */ } /* dorgbr_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

98
lib/linalg/dorgl2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorgl2.f -- translated by f2c (version 20200916). /* fortran/dorgl2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -130,7 +130,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal * /* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *info) a, integer *lda, doublereal *tau, doublereal *work, integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2; integer a_dim1, a_offset, i__1, i__2;
@ -138,10 +138,10 @@ f"> */
/* Local variables */ /* Local variables */
integer i__, j, l; integer i__, j, l;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *, integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */ /* -- LAPACK computational routine -- */
@ -177,70 +177,70 @@ f"> */
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < *m) { } else if (*n < *m) {
*info = -2; *info = -2;
} else if (*k < 0 || *k > *m) { } else if (*k < 0 || *k > *m) {
*info = -3; *info = -3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -5; *info = -5;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORGL2", &i__1, (ftnlen)6); xerbla_((char *)"DORGL2", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m <= 0) { if (*m <= 0) {
return 0; return 0;
} }
if (*k < *m) { if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */ /* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (l = *k + 1; l <= i__2; ++l) { for (l = *k + 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.; a[l + j * a_dim1] = 0.;
/* L10: */ /* L10: */
} }
if (j > *k && j <= *m) { if (j > *k && j <= *m) {
a[j + j * a_dim1] = 1.; a[j + j * a_dim1] = 1.;
} }
/* L20: */ /* L20: */
} }
} }
for (i__ = *k; i__ >= 1; --i__) { for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i) to A(i:m,i:n) from the right */ /* Apply H(i) to A(i:m,i:n) from the right */
if (i__ < *n) { if (i__ < *n) {
if (i__ < *m) { if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
i__1 = *m - i__; i__1 = *m - i__;
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
dlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & dlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], ( tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (
ftnlen)5); ftnlen)5);
} }
i__1 = *n - i__; i__1 = *n - i__;
d__1 = -tau[i__]; d__1 = -tau[i__];
dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda); dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda);
} }
a[i__ + i__ * a_dim1] = 1. - tau[i__]; a[i__ + i__ * a_dim1] = 1. - tau[i__];
/* Set A(i,1:i-1) to zero */ /* Set A(i,1:i-1) to zero */
i__1 = i__ - 1; i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) { for (l = 1; l <= i__1; ++l) {
a[i__ + l * a_dim1] = 0.; a[i__ + l * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
return 0; return 0;
@ -250,5 +250,5 @@ f"> */
} /* dorgl2_ */ } /* dorgl2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

176
lib/linalg/dorglq.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorglq.f -- translated by f2c (version 20200916). /* fortran/dorglq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -151,24 +151,24 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal * /* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
integer *info) integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */ /* Local variables */
integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dorgl2_(integer *, integer *, integer *, extern /* Subroutine */ int dorgl2_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), doublereal *, integer *, doublereal *, doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, dlarfb_(char *, char *, char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer ldwork, lwkopt; integer ldwork, lwkopt;
logical lquery; logical lquery;
@ -212,29 +212,29 @@ f"> */
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
lquery = *lwork == -1; lquery = *lwork == -1;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < *m) { } else if (*n < *m) {
*info = -2; *info = -2;
} else if (*k < 0 || *k > *m) { } else if (*k < 0 || *k > *m) {
*info = -3; *info = -3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -5; *info = -5;
} else if (*lwork < max(1,*m) && ! lquery) { } else if (*lwork < max(1,*m) && ! lquery) {
*info = -8; *info = -8;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORGLQ", &i__1, (ftnlen)6); xerbla_((char *)"DORGLQ", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m <= 0) { if (*m <= 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
@ -245,27 +245,27 @@ f"> */
/* Determine when to cross over from blocked to unblocked code. */ /* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */ /* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, ( i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2); nx = max(i__1,i__2);
if (nx < *k) { if (nx < *k) {
/* Determine if workspace is large enough for blocked code. */ /* Determine if workspace is large enough for blocked code. */
ldwork = *m; ldwork = *m;
iws = ldwork * nb; iws = ldwork * nb;
if (*lwork < iws) { if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */ /* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */ /* determine the minimum value of NB. */
nb = *lwork / ldwork; nb = *lwork / ldwork;
/* Computing MAX */ /* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1,
(ftnlen)6, (ftnlen)1); (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
} }
if (nb >= nbmin && nb < *k && nx < *k) { if (nb >= nbmin && nb < *k && nx < *k) {
@ -273,85 +273,85 @@ f"> */
/* Use blocked code after the last block. */ /* Use blocked code after the last block. */
/* The first kk rows are handled by the block method. */ /* The first kk rows are handled by the block method. */
ki = (*k - nx - 1) / nb * nb; ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */ /* Computing MIN */
i__1 = *k, i__2 = ki + nb; i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2); kk = min(i__1,i__2);
/* Set A(kk+1:m,1:kk) to zero. */ /* Set A(kk+1:m,1:kk) to zero. */
i__1 = kk; i__1 = kk;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = kk + 1; i__ <= i__2; ++i__) { for (i__ = kk + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.; a[i__ + j * a_dim1] = 0.;
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else { } else {
kk = 0; kk = 0;
} }
/* Use unblocked code for the last or only block. */ /* Use unblocked code for the last or only block. */
if (kk < *m) { if (kk < *m) {
i__1 = *m - kk; i__1 = *m - kk;
i__2 = *n - kk; i__2 = *n - kk;
i__3 = *k - kk; i__3 = *k - kk;
dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo); tau[kk + 1], &work[1], &iinfo);
} }
if (kk > 0) { if (kk > 0) {
/* Use blocked code */ /* Use blocked code */
i__1 = -nb; i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */ /* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1; i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3); ib = min(i__2,i__3);
if (i__ + ib <= *m) { if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */ /* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
dlarft_((char *)"Forward", (char *)"Rowwise", &i__2, &ib, &a[i__ + i__ * dlarft_((char *)"Forward", (char *)"Rowwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)7); (ftnlen)7);
/* Apply H**T to A(i+ib:m,i:n) from the right */ /* Apply H**T to A(i+ib:m,i:n) from the right */
i__2 = *m - i__ - ib + 1; i__2 = *m - i__ - ib + 1;
i__3 = *n - i__ + 1; i__3 = *n - i__ + 1;
dlarfb_((char *)"Right", (char *)"Transpose", (char *)"Forward", (char *)"Rowwise", &i__2, & dlarfb_((char *)"Right", (char *)"Transpose", (char *)"Forward", (char *)"Rowwise", &i__2, &
i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
1], &ldwork, (ftnlen)5, (ftnlen)9, (ftnlen)7, (ftnlen) 1], &ldwork, (ftnlen)5, (ftnlen)9, (ftnlen)7, (ftnlen)
7); 7);
} }
/* Apply H**T to columns i:n of current block */ /* Apply H**T to columns i:n of current block */
i__2 = *n - i__ + 1; i__2 = *n - i__ + 1;
dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo); work[1], &iinfo);
/* Set columns 1:i-1 of current block to zero */ /* Set columns 1:i-1 of current block to zero */
i__2 = i__ - 1; i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) { for (j = 1; j <= i__2; ++j) {
i__3 = i__ + ib - 1; i__3 = i__ + ib - 1;
for (l = i__; l <= i__3; ++l) { for (l = i__; l <= i__3; ++l) {
a[l + j * a_dim1] = 0.; a[l + j * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
/* L50: */ /* L50: */
} }
} }
work[1] = (doublereal) iws; work[1] = (doublereal) iws;
@ -362,5 +362,5 @@ f"> */
} /* dorglq_ */ } /* dorglq_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

188
lib/linalg/dorgql.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorgql.f -- translated by f2c (version 20200916). /* fortran/dorgql.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -152,24 +152,24 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal * /* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
integer *info) integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4; integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo; integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *, extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), doublereal *, integer *, doublereal *, doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, dlarfb_(char *, char *, char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer ldwork, lwkopt; integer ldwork, lwkopt;
logical lquery; logical lquery;
@ -210,42 +210,42 @@ f"> */
*info = 0; *info = 0;
lquery = *lwork == -1; lquery = *lwork == -1;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0 || *n > *m) { } else if (*n < 0 || *n > *m) {
*info = -2; *info = -2;
} else if (*k < 0 || *k > *n) { } else if (*k < 0 || *k > *n) {
*info = -3; *info = -3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -5; *info = -5;
} }
if (*info == 0) { if (*info == 0) {
if (*n == 0) { if (*n == 0) {
lwkopt = 1; lwkopt = 1;
} else { } else {
nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, ( nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (
ftnlen)1); ftnlen)1);
lwkopt = *n * nb; lwkopt = *n * nb;
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
if (*lwork < max(1,*n) && ! lquery) { if (*lwork < max(1,*n) && ! lquery) {
*info = -8; *info = -8;
} }
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORGQL", &i__1, (ftnlen)6); xerbla_((char *)"DORGQL", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n <= 0) { if (*n <= 0) {
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
@ -256,27 +256,27 @@ f"> */
/* Determine when to cross over from blocked to unblocked code. */ /* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */ /* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, ( i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2); nx = max(i__1,i__2);
if (nx < *k) { if (nx < *k) {
/* Determine if workspace is large enough for blocked code. */ /* Determine if workspace is large enough for blocked code. */
ldwork = *n; ldwork = *n;
iws = ldwork * nb; iws = ldwork * nb;
if (*lwork < iws) { if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */ /* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */ /* determine the minimum value of NB. */
nb = *lwork / ldwork; nb = *lwork / ldwork;
/* Computing MAX */ /* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1,
(ftnlen)6, (ftnlen)1); (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
} }
if (nb >= nbmin && nb < *k && nx < *k) { if (nb >= nbmin && nb < *k && nx < *k) {
@ -285,22 +285,22 @@ f"> */
/* The last kk columns are handled by the block method. */ /* The last kk columns are handled by the block method. */
/* Computing MIN */ /* Computing MIN */
i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
kk = min(i__1,i__2); kk = min(i__1,i__2);
/* Set A(m-kk+1:m,1:n-kk) to zero. */ /* Set A(m-kk+1:m,1:n-kk) to zero. */
i__1 = *n - kk; i__1 = *n - kk;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = *m; i__2 = *m;
for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.; a[i__ + j * a_dim1] = 0.;
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else { } else {
kk = 0; kk = 0;
} }
/* Use unblocked code for the first or only block. */ /* Use unblocked code for the first or only block. */
@ -309,59 +309,59 @@ f"> */
i__2 = *n - kk; i__2 = *n - kk;
i__3 = *k - kk; i__3 = *k - kk;
dorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) dorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
; ;
if (kk > 0) { if (kk > 0) {
/* Use blocked code */ /* Use blocked code */
i__1 = *k; i__1 = *k;
i__2 = nb; i__2 = nb;
for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
i__2) { i__2) {
/* Computing MIN */ /* Computing MIN */
i__3 = nb, i__4 = *k - i__ + 1; i__3 = nb, i__4 = *k - i__ + 1;
ib = min(i__3,i__4); ib = min(i__3,i__4);
if (*n - *k + i__ > 1) { if (*n - *k + i__ > 1) {
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i+ib-1) . . . H(i+1) H(i) */ /* H = H(i+ib-1) . . . H(i+1) H(i) */
i__3 = *m - *k + i__ + ib - 1; i__3 = *m - *k + i__ + ib - 1;
dlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + dlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k +
i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork, i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork,
(ftnlen)8, (ftnlen)10); (ftnlen)8, (ftnlen)10);
/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ /* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
i__3 = *m - *k + i__ + ib - 1; i__3 = *m - *k + i__ + ib - 1;
i__4 = *n - *k + i__ - 1; i__4 = *n - *k + i__ - 1;
dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", & dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", &
i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1],
lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib +
1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, ( 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, (
ftnlen)10); ftnlen)10);
} }
/* Apply H to rows 1:m-k+i+ib-1 of current block */ /* Apply H to rows 1:m-k+i+ib-1 of current block */
i__3 = *m - *k + i__ + ib - 1; i__3 = *m - *k + i__ + ib - 1;
dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &
tau[i__], &work[1], &iinfo); tau[i__], &work[1], &iinfo);
/* Set rows m-k+i+ib:m of current block to zero */ /* Set rows m-k+i+ib:m of current block to zero */
i__3 = *n - *k + i__ + ib - 1; i__3 = *n - *k + i__ + ib - 1;
for (j = *n - *k + i__; j <= i__3; ++j) { for (j = *n - *k + i__; j <= i__3; ++j) {
i__4 = *m; i__4 = *m;
for (l = *m - *k + i__ + ib; l <= i__4; ++l) { for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
a[l + j * a_dim1] = 0.; a[l + j * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
/* L50: */ /* L50: */
} }
} }
work[1] = (doublereal) iws; work[1] = (doublereal) iws;
@ -372,5 +372,5 @@ f"> */
} /* dorgql_ */ } /* dorgql_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

176
lib/linalg/dorgqr.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorgqr.f -- translated by f2c (version 20200916). /* fortran/dorgqr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -152,24 +152,24 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal * /* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
integer *info) integer *info)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */ /* Local variables */
integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dorg2r_(integer *, integer *, integer *, extern /* Subroutine */ int dorg2r_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), doublereal *, integer *, doublereal *, doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, dlarfb_(char *, char *, char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
integer ldwork, lwkopt; integer ldwork, lwkopt;
logical lquery; logical lquery;
@ -213,29 +213,29 @@ f"> */
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
lquery = *lwork == -1; lquery = *lwork == -1;
if (*m < 0) { if (*m < 0) {
*info = -1; *info = -1;
} else if (*n < 0 || *n > *m) { } else if (*n < 0 || *n > *m) {
*info = -2; *info = -2;
} else if (*k < 0 || *k > *n) { } else if (*k < 0 || *k > *n) {
*info = -3; *info = -3;
} else if (*lda < max(1,*m)) { } else if (*lda < max(1,*m)) {
*info = -5; *info = -5;
} else if (*lwork < max(1,*n) && ! lquery) { } else if (*lwork < max(1,*n) && ! lquery) {
*info = -8; *info = -8;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORGQR", &i__1, (ftnlen)6); xerbla_((char *)"DORGQR", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n <= 0) { if (*n <= 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
@ -246,27 +246,27 @@ f"> */
/* Determine when to cross over from blocked to unblocked code. */ /* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */ /* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, ( i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2); nx = max(i__1,i__2);
if (nx < *k) { if (nx < *k) {
/* Determine if workspace is large enough for blocked code. */ /* Determine if workspace is large enough for blocked code. */
ldwork = *n; ldwork = *n;
iws = ldwork * nb; iws = ldwork * nb;
if (*lwork < iws) { if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */ /* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */ /* determine the minimum value of NB. */
nb = *lwork / ldwork; nb = *lwork / ldwork;
/* Computing MAX */ /* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1,
(ftnlen)6, (ftnlen)1); (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
} }
if (nb >= nbmin && nb < *k && nx < *k) { if (nb >= nbmin && nb < *k && nx < *k) {
@ -274,85 +274,85 @@ f"> */
/* Use blocked code after the last block. */ /* Use blocked code after the last block. */
/* The first kk columns are handled by the block method. */ /* The first kk columns are handled by the block method. */
ki = (*k - nx - 1) / nb * nb; ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */ /* Computing MIN */
i__1 = *k, i__2 = ki + nb; i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2); kk = min(i__1,i__2);
/* Set A(1:kk,kk+1:n) to zero. */ /* Set A(1:kk,kk+1:n) to zero. */
i__1 = *n; i__1 = *n;
for (j = kk + 1; j <= i__1; ++j) { for (j = kk + 1; j <= i__1; ++j) {
i__2 = kk; i__2 = kk;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.; a[i__ + j * a_dim1] = 0.;
/* L10: */ /* L10: */
} }
/* L20: */ /* L20: */
} }
} else { } else {
kk = 0; kk = 0;
} }
/* Use unblocked code for the last or only block. */ /* Use unblocked code for the last or only block. */
if (kk < *n) { if (kk < *n) {
i__1 = *m - kk; i__1 = *m - kk;
i__2 = *n - kk; i__2 = *n - kk;
i__3 = *k - kk; i__3 = *k - kk;
dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo); tau[kk + 1], &work[1], &iinfo);
} }
if (kk > 0) { if (kk > 0) {
/* Use blocked code */ /* Use blocked code */
i__1 = -nb; i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */ /* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1; i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3); ib = min(i__2,i__3);
if (i__ + ib <= *n) { if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */ /* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
dlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * dlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)10); (ftnlen)10);
/* Apply H to A(i:m,i+ib:n) from the left */ /* Apply H to A(i:m,i+ib:n) from the left */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
i__3 = *n - i__ - ib + 1; i__3 = *n - i__ - ib + 1;
dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", & dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", &
i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen) work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)
7, (ftnlen)10); 7, (ftnlen)10);
} }
/* Apply H to rows i:m of current block */ /* Apply H to rows i:m of current block */
i__2 = *m - i__ + 1; i__2 = *m - i__ + 1;
dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo); work[1], &iinfo);
/* Set rows 1:i-1 of current block to zero */ /* Set rows 1:i-1 of current block to zero */
i__2 = i__ + ib - 1; i__2 = i__ + ib - 1;
for (j = i__; j <= i__2; ++j) { for (j = i__; j <= i__2; ++j) {
i__3 = i__ - 1; i__3 = i__ - 1;
for (l = 1; l <= i__3; ++l) { for (l = 1; l <= i__3; ++l) {
a[l + j * a_dim1] = 0.; a[l + j * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
/* L40: */ /* L40: */
} }
/* L50: */ /* L50: */
} }
} }
work[1] = (doublereal) iws; work[1] = (doublereal) iws;
@ -363,5 +363,5 @@ f"> */
} /* dorgqr_ */ } /* dorgqr_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

164
lib/linalg/dorgtr.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorgtr.f -- translated by f2c (version 20200916). /* fortran/dorgtr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -145,8 +145,8 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer * /* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info, lda, doublereal *tau, doublereal *work, integer *lwork, integer *info,
ftnlen uplo_len) ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -157,12 +157,12 @@ f"> */
integer iinfo; integer iinfo;
logical upper; logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dorgql_(integer *, integer *, integer *, extern /* Subroutine */ int dorgql_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dorgqr_(integer *, integer *, integer *, doublereal *, integer *), dorgqr_(integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *); integer *, doublereal *, doublereal *, integer *, integer *);
integer lwkopt; integer lwkopt;
logical lquery; logical lquery;
@ -204,52 +204,52 @@ f"> */
lquery = *lwork == -1; lquery = *lwork == -1;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*n)) { } else if (*lda < max(1,*n)) {
*info = -4; *info = -4;
} else /* if(complicated condition) */ { } else /* if(complicated condition) */ {
/* Computing MAX */ /* Computing MAX */
i__1 = 1, i__2 = *n - 1; i__1 = 1, i__2 = *n - 1;
if (*lwork < max(i__1,i__2) && ! lquery) { if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -7; *info = -7;
} }
} }
if (*info == 0) { if (*info == 0) {
if (upper) { if (upper) {
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
} else { } else {
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)1); ftnlen)6, (ftnlen)1);
} }
/* Computing MAX */ /* Computing MAX */
i__1 = 1, i__2 = *n - 1; i__1 = 1, i__2 = *n - 1;
lwkopt = max(i__1,i__2) * nb; lwkopt = max(i__1,i__2) * nb;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORGTR", &i__1, (ftnlen)6); xerbla_((char *)"DORGTR", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
if (upper) { if (upper) {
@ -260,30 +260,30 @@ f"> */
/* column to the left, and set the last row and column of Q to */ /* column to the left, and set the last row and column of Q to */
/* those of the unit matrix */ /* those of the unit matrix */
i__1 = *n - 1; i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j - 1; i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1]; a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1];
/* L10: */ /* L10: */
} }
a[*n + j * a_dim1] = 0.; a[*n + j * a_dim1] = 0.;
/* L20: */ /* L20: */
} }
i__1 = *n - 1; i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + *n * a_dim1] = 0.; a[i__ + *n * a_dim1] = 0.;
/* L30: */ /* L30: */
} }
a[*n + *n * a_dim1] = 1.; a[*n + *n * a_dim1] = 1.;
/* Generate Q(1:n-1,1:n-1) */ /* Generate Q(1:n-1,1:n-1) */
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1],
lwork, &iinfo); lwork, &iinfo);
} else { } else {
@ -293,31 +293,31 @@ f"> */
/* column to the right, and set the first row and column of Q to */ /* column to the right, and set the first row and column of Q to */
/* those of the unit matrix */ /* those of the unit matrix */
for (j = *n; j >= 2; --j) { for (j = *n; j >= 2; --j) {
a[j * a_dim1 + 1] = 0.; a[j * a_dim1 + 1] = 0.;
i__1 = *n; i__1 = *n;
for (i__ = j + 1; i__ <= i__1; ++i__) { for (i__ = j + 1; i__ <= i__1; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
/* L40: */ /* L40: */
} }
/* L50: */ /* L50: */
} }
a[a_dim1 + 1] = 1.; a[a_dim1 + 1] = 1.;
i__1 = *n; i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) { for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.; a[i__ + a_dim1] = 0.;
/* L60: */ /* L60: */
} }
if (*n > 1) { if (*n > 1) {
/* Generate Q(2:n,2:n) */ /* Generate Q(2:n,2:n) */
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1],
&work[1], lwork, &iinfo); &work[1], lwork, &iinfo);
} }
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
@ -327,5 +327,5 @@ f"> */
} /* dorgtr_ */ } /* dorgtr_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

94
lib/linalg/dorm2l.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorm2l.f -- translated by f2c (version 20200916). /* fortran/dorm2l.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -19,7 +19,7 @@ extern "C" {
static integer c__1 = 1; static integer c__1 = 1;
/* > \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined /* > \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined
by sgeqlf (unblocked algorithm). */ by sgeqlf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */ /* =========== DOCUMENTATION =========== */
@ -179,10 +179,10 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n, /* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len,
ftnlen trans_len) ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
@ -191,9 +191,9 @@ f"> */
integer i__, i1, i2, i3, mi, ni, nq; integer i__, i1, i2, i3, mi, ni, nq;
doublereal aii; doublereal aii;
logical left; logical left;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *, extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen); doublereal *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical notran; logical notran;
@ -242,75 +242,75 @@ f"> */
/* NQ is the order of Q */ /* NQ is the order of Q */
if (left) { if (left) {
nq = *m; nq = *m;
} else { } else {
nq = *n; nq = *n;
} }
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (*m < 0) { } else if (*m < 0) {
*info = -3; *info = -3;
} else if (*n < 0) { } else if (*n < 0) {
*info = -4; *info = -4;
} else if (*k < 0 || *k > nq) { } else if (*k < 0 || *k > nq) {
*info = -5; *info = -5;
} else if (*lda < max(1,nq)) { } else if (*lda < max(1,nq)) {
*info = -7; *info = -7;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -10; *info = -10;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORM2L", &i__1, (ftnlen)6); xerbla_((char *)"DORM2L", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) { if (*m == 0 || *n == 0 || *k == 0) {
return 0; return 0;
} }
if (left && notran || ! left && ! notran) { if (left && notran || ! left && ! notran) {
i1 = 1; i1 = 1;
i2 = *k; i2 = *k;
i3 = 1; i3 = 1;
} else { } else {
i1 = *k; i1 = *k;
i2 = 1; i2 = 1;
i3 = -1; i3 = -1;
} }
if (left) { if (left) {
ni = *n; ni = *n;
} else { } else {
mi = *m; mi = *m;
} }
i__1 = i2; i__1 = i2;
i__2 = i3; i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) { if (left) {
/* H(i) is applied to C(1:m-k+i,1:n) */ /* H(i) is applied to C(1:m-k+i,1:n) */
mi = *m - *k + i__; mi = *m - *k + i__;
} else { } else {
/* H(i) is applied to C(1:m,1:n-k+i) */ /* H(i) is applied to C(1:m,1:n-k+i) */
ni = *n - *k + i__; ni = *n - *k + i__;
} }
/* Apply H(i) */ /* Apply H(i) */
aii = a[nq - *k + i__ + i__ * a_dim1]; aii = a[nq - *k + i__ + i__ * a_dim1];
a[nq - *k + i__ + i__ * a_dim1] = 1.; a[nq - *k + i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[ dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[
c_offset], ldc, &work[1], (ftnlen)1); c_offset], ldc, &work[1], (ftnlen)1);
a[nq - *k + i__ + i__ * a_dim1] = aii; a[nq - *k + i__ + i__ * a_dim1] = aii;
/* L10: */ /* L10: */
} }
return 0; return 0;
@ -320,5 +320,5 @@ f"> */
} /* dorm2l_ */ } /* dorm2l_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

102
lib/linalg/dorm2r.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorm2r.f -- translated by f2c (version 20200916). /* fortran/dorm2r.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -19,7 +19,7 @@ extern "C" {
static integer c__1 = 1; static integer c__1 = 1;
/* > \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined /* > \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined
by sgeqrf (unblocked algorithm). */ by sgeqrf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */ /* =========== DOCUMENTATION =========== */
@ -179,10 +179,10 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, /* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len,
ftnlen trans_len) ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
@ -191,9 +191,9 @@ f"> */
integer i__, i1, i2, i3, ic, jc, mi, ni, nq; integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
doublereal aii; doublereal aii;
logical left; logical left;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *, extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen); doublereal *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical notran; logical notran;
@ -242,79 +242,79 @@ f"> */
/* NQ is the order of Q */ /* NQ is the order of Q */
if (left) { if (left) {
nq = *m; nq = *m;
} else { } else {
nq = *n; nq = *n;
} }
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (*m < 0) { } else if (*m < 0) {
*info = -3; *info = -3;
} else if (*n < 0) { } else if (*n < 0) {
*info = -4; *info = -4;
} else if (*k < 0 || *k > nq) { } else if (*k < 0 || *k > nq) {
*info = -5; *info = -5;
} else if (*lda < max(1,nq)) { } else if (*lda < max(1,nq)) {
*info = -7; *info = -7;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -10; *info = -10;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORM2R", &i__1, (ftnlen)6); xerbla_((char *)"DORM2R", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) { if (*m == 0 || *n == 0 || *k == 0) {
return 0; return 0;
} }
if (left && ! notran || ! left && notran) { if (left && ! notran || ! left && notran) {
i1 = 1; i1 = 1;
i2 = *k; i2 = *k;
i3 = 1; i3 = 1;
} else { } else {
i1 = *k; i1 = *k;
i2 = 1; i2 = 1;
i3 = -1; i3 = -1;
} }
if (left) { if (left) {
ni = *n; ni = *n;
jc = 1; jc = 1;
} else { } else {
mi = *m; mi = *m;
ic = 1; ic = 1;
} }
i__1 = i2; i__1 = i2;
i__2 = i3; i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) { if (left) {
/* H(i) is applied to C(i:m,1:n) */ /* H(i) is applied to C(i:m,1:n) */
mi = *m - i__ + 1; mi = *m - i__ + 1;
ic = i__; ic = i__;
} else { } else {
/* H(i) is applied to C(1:m,i:n) */ /* H(i) is applied to C(1:m,i:n) */
ni = *n - i__ + 1; ni = *n - i__ + 1;
jc = i__; jc = i__;
} }
/* Apply H(i) */ /* Apply H(i) */
aii = a[i__ + i__ * a_dim1]; aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
ic + jc * c_dim1], ldc, &work[1], (ftnlen)1); ic + jc * c_dim1], ldc, &work[1], (ftnlen)1);
a[i__ + i__ * a_dim1] = aii; a[i__ + i__ * a_dim1] = aii;
/* L10: */ /* L10: */
} }
return 0; return 0;
@ -324,5 +324,5 @@ f"> */
} /* dorm2r_ */ } /* dorm2r_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

258
lib/linalg/dormbr.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dormbr.f -- translated by f2c (version 20200916). /* fortran/dormbr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -216,10 +216,10 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m, /* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m,
integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *c__, integer *ldc, doublereal *work, integer *lwork, doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
integer *info, ftnlen vect_len, ftnlen side_len, ftnlen trans_len) integer *info, ftnlen vect_len, ftnlen side_len, ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
address a__1[2]; address a__1[2];
@ -235,15 +235,15 @@ f"> */
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer iinfo; integer iinfo;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
logical notran; logical notran;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
logical applyq; logical applyq;
char transt[1]; char transt[1];
integer lwkopt; integer lwkopt;
@ -293,164 +293,164 @@ f"> */
/* NQ is the order of Q or P and NW is the minimum dimension of WORK */ /* NQ is the order of Q or P and NW is the minimum dimension of WORK */
if (left) { if (left) {
nq = *m; nq = *m;
nw = max(1,*n); nw = max(1,*n);
} else { } else {
nq = *n; nq = *n;
nw = max(1,*m); nw = max(1,*m);
} }
if (! applyq && ! lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) { if (! applyq && ! lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { } else if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -3; *info = -3;
} else if (*m < 0) { } else if (*m < 0) {
*info = -4; *info = -4;
} else if (*n < 0) { } else if (*n < 0) {
*info = -5; *info = -5;
} else if (*k < 0) { } else if (*k < 0) {
*info = -6; *info = -6;
} else /* if(complicated condition) */ { } else /* if(complicated condition) */ {
/* Computing MAX */ /* Computing MAX */
i__1 = 1, i__2 = min(nq,*k); i__1 = 1, i__2 = min(nq,*k);
if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) { if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
*info = -8; *info = -8;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -11; *info = -11;
} else if (*lwork < nw && ! lquery) { } else if (*lwork < nw && ! lquery) {
*info = -13; *info = -13;
} }
} }
if (*info == 0) { if (*info == 0) {
if (applyq) { if (applyq) {
if (left) { if (left) {
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *m - 1; i__1 = *m - 1;
i__2 = *m - 1; i__2 = *m - 1;
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__1, n, &i__2, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__1, n, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} else { } else {
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__1, &i__2, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__1, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} }
} else { } else {
if (left) { if (left) {
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *m - 1; i__1 = *m - 1;
i__2 = *m - 1; i__2 = *m - 1;
nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} else { } else {
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *n - 1; i__1 = *n - 1;
i__2 = *n - 1; i__2 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} }
} }
lwkopt = nw * nb; lwkopt = nw * nb;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORMBR", &i__1, (ftnlen)6); xerbla_((char *)"DORMBR", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
work[1] = 1.; work[1] = 1.;
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
return 0; return 0;
} }
if (applyq) { if (applyq) {
/* Apply Q */ /* Apply Q */
if (nq >= *k) { if (nq >= *k) {
/* Q was determined by a call to DGEBRD with nq >= k */ /* Q was determined by a call to DGEBRD with nq >= k */
dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, ( c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (
ftnlen)1); ftnlen)1);
} else if (nq > 1) { } else if (nq > 1) {
/* Q was determined by a call to DGEBRD with nq < k */ /* Q was determined by a call to DGEBRD with nq < k */
if (left) { if (left) {
mi = *m - 1; mi = *m - 1;
ni = *n; ni = *n;
i1 = 2; i1 = 2;
i2 = 1; i2 = 1;
} else { } else {
mi = *m; mi = *m;
ni = *n - 1; ni = *n - 1;
i1 = 1; i1 = 1;
i2 = 2; i2 = 2;
} }
i__1 = nq - 1; i__1 = nq - 1;
dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, ( , &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (
ftnlen)1, (ftnlen)1); ftnlen)1, (ftnlen)1);
} }
} else { } else {
/* Apply P */ /* Apply P */
if (notran) { if (notran) {
*(unsigned char *)transt = 'T'; *(unsigned char *)transt = 'T';
} else { } else {
*(unsigned char *)transt = 'N'; *(unsigned char *)transt = 'N';
} }
if (nq > *k) { if (nq > *k) {
/* P was determined by a call to DGEBRD with nq > k */ /* P was determined by a call to DGEBRD with nq > k */
dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, ( c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (
ftnlen)1); ftnlen)1);
} else if (nq > 1) { } else if (nq > 1) {
/* P was determined by a call to DGEBRD with nq <= k */ /* P was determined by a call to DGEBRD with nq <= k */
if (left) { if (left) {
mi = *m - 1; mi = *m - 1;
ni = *n; ni = *n;
i1 = 2; i1 = 2;
i2 = 1; i2 = 1;
} else { } else {
mi = *m; mi = *m;
ni = *n - 1; ni = *n - 1;
i1 = 1; i1 = 1;
i2 = 2; i2 = 2;
} }
i__1 = nq - 1; i__1 = nq - 1;
dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
&tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
iinfo, (ftnlen)1, (ftnlen)1); iinfo, (ftnlen)1, (ftnlen)1);
} }
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
@ -460,5 +460,5 @@ f"> */
} /* dormbr_ */ } /* dormbr_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

102
lib/linalg/dorml2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dorml2.f -- translated by f2c (version 20200916). /* fortran/dorml2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -15,7 +15,7 @@ extern "C" {
#endif #endif
#include "lmp_f2c.h" #include "lmp_f2c.h"
/* > \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined /* > \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined
by sgelqf (unblocked algorithm). */ by sgelqf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */ /* =========== DOCUMENTATION =========== */
@ -175,10 +175,10 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n, /* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len,
ftnlen trans_len) ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
@ -187,9 +187,9 @@ f"> */
integer i__, i1, i2, i3, ic, jc, mi, ni, nq; integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
doublereal aii; doublereal aii;
logical left; logical left;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *, extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen); doublereal *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical notran; logical notran;
@ -238,79 +238,79 @@ f"> */
/* NQ is the order of Q */ /* NQ is the order of Q */
if (left) { if (left) {
nq = *m; nq = *m;
} else { } else {
nq = *n; nq = *n;
} }
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (*m < 0) { } else if (*m < 0) {
*info = -3; *info = -3;
} else if (*n < 0) { } else if (*n < 0) {
*info = -4; *info = -4;
} else if (*k < 0 || *k > nq) { } else if (*k < 0 || *k > nq) {
*info = -5; *info = -5;
} else if (*lda < max(1,*k)) { } else if (*lda < max(1,*k)) {
*info = -7; *info = -7;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -10; *info = -10;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORML2", &i__1, (ftnlen)6); xerbla_((char *)"DORML2", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) { if (*m == 0 || *n == 0 || *k == 0) {
return 0; return 0;
} }
if (left && notran || ! left && ! notran) { if (left && notran || ! left && ! notran) {
i1 = 1; i1 = 1;
i2 = *k; i2 = *k;
i3 = 1; i3 = 1;
} else { } else {
i1 = *k; i1 = *k;
i2 = 1; i2 = 1;
i3 = -1; i3 = -1;
} }
if (left) { if (left) {
ni = *n; ni = *n;
jc = 1; jc = 1;
} else { } else {
mi = *m; mi = *m;
ic = 1; ic = 1;
} }
i__1 = i2; i__1 = i2;
i__2 = i3; i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) { if (left) {
/* H(i) is applied to C(i:m,1:n) */ /* H(i) is applied to C(i:m,1:n) */
mi = *m - i__ + 1; mi = *m - i__ + 1;
ic = i__; ic = i__;
} else { } else {
/* H(i) is applied to C(1:m,i:n) */ /* H(i) is applied to C(1:m,i:n) */
ni = *n - i__ + 1; ni = *n - i__ + 1;
jc = i__; jc = i__;
} }
/* Apply H(i) */ /* Apply H(i) */
aii = a[i__ + i__ * a_dim1]; aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.; a[i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[
ic + jc * c_dim1], ldc, &work[1], (ftnlen)1); ic + jc * c_dim1], ldc, &work[1], (ftnlen)1);
a[i__ + i__ * a_dim1] = aii; a[i__ + i__ * a_dim1] = aii;
/* L10: */ /* L10: */
} }
return 0; return 0;
@ -320,5 +320,5 @@ f"> */
} /* dorml2_ */ } /* dorml2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

208
lib/linalg/dormlq.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dormlq.f -- translated by f2c (version 20200916). /* fortran/dormlq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -189,15 +189,15 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, /* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info, c__, integer *ldc, doublereal *work, integer *lwork, integer *info,
ftnlen side_len, ftnlen trans_len) ftnlen side_len, ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
address a__1[2]; address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5; i__5;
char ch__1[2]; char ch__1[2];
/* Builtin functions */ /* Builtin functions */
@ -208,17 +208,17 @@ f"> */
logical left; logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nbmin, iinfo; integer nbmin, iinfo;
extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *, extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char
*, char *, char *, char *, integer *, integer *, integer *, *, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen, *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
logical notran; logical notran;
integer ldwork; integer ldwork;
char transt[1]; char transt[1];
@ -270,28 +270,28 @@ f"> */
/* NQ is the order of Q and NW is the minimum dimension of WORK */ /* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) { if (left) {
nq = *m; nq = *m;
nw = max(1,*n); nw = max(1,*n);
} else { } else {
nq = *n; nq = *n;
nw = max(1,*m); nw = max(1,*m);
} }
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (*m < 0) { } else if (*m < 0) {
*info = -3; *info = -3;
} else if (*n < 0) { } else if (*n < 0) {
*info = -4; *info = -4;
} else if (*k < 0 || *k > nq) { } else if (*k < 0 || *k > nq) {
*info = -5; *info = -5;
} else if (*lda < max(1,*k)) { } else if (*lda < max(1,*k)) {
*info = -7; *info = -7;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -10; *info = -10;
} else if (*lwork < nw && ! lquery) { } else if (*lwork < nw && ! lquery) {
*info = -12; *info = -12;
} }
if (*info == 0) { if (*info == 0) {
@ -300,117 +300,117 @@ f"> */
/* Computing MIN */ /* Computing MIN */
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, ( i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2); nb = min(i__1,i__2);
lwkopt = nw * nb + 4160; lwkopt = nw * nb + 4160;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORMLQ", &i__1, (ftnlen)6); xerbla_((char *)"DORMLQ", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) { if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
ldwork = nw; ldwork = nw;
if (nb > 1 && nb < *k) { if (nb > 1 && nb < *k) {
if (*lwork < lwkopt) { if (*lwork < lwkopt) {
nb = (*lwork - 4160) / ldwork; nb = (*lwork - 4160) / ldwork;
/* Computing MAX */ /* Computing MAX */
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, ( i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
if (nb < nbmin || nb >= *k) { if (nb < nbmin || nb >= *k) {
/* Use unblocked code */ /* Use unblocked code */
dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1);
} else { } else {
/* Use blocked code */ /* Use blocked code */
iwt = nw * nb + 1; iwt = nw * nb + 1;
if (left && notran || ! left && ! notran) { if (left && notran || ! left && ! notran) {
i1 = 1; i1 = 1;
i2 = *k; i2 = *k;
i3 = nb; i3 = nb;
} else { } else {
i1 = (*k - 1) / nb * nb + 1; i1 = (*k - 1) / nb * nb + 1;
i2 = 1; i2 = 1;
i3 = -nb; i3 = -nb;
} }
if (left) { if (left) {
ni = *n; ni = *n;
jc = 1; jc = 1;
} else { } else {
mi = *m; mi = *m;
ic = 1; ic = 1;
} }
if (notran) { if (notran) {
*(unsigned char *)transt = 'T'; *(unsigned char *)transt = 'T';
} else { } else {
*(unsigned char *)transt = 'N'; *(unsigned char *)transt = 'N';
} }
i__1 = i2; i__1 = i2;
i__2 = i3; i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */ /* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1; i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5); ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */ /* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1; i__4 = nq - i__ + 1;
dlarft_((char *)"Forward", (char *)"Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], dlarft_((char *)"Forward", (char *)"Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, (ftnlen)7); lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, (ftnlen)7);
if (left) { if (left) {
/* H or H**T is applied to C(i:m,1:n) */ /* H or H**T is applied to C(i:m,1:n) */
mi = *m - i__ + 1; mi = *m - i__ + 1;
ic = i__; ic = i__;
} else { } else {
/* H or H**T is applied to C(1:m,i:n) */ /* H or H**T is applied to C(1:m,i:n) */
ni = *n - i__ + 1; ni = *n - i__ + 1;
jc = i__; jc = i__;
} }
/* Apply H or H**T */ /* Apply H or H**T */
dlarfb_(side, transt, (char *)"Forward", (char *)"Rowwise", &mi, &ni, &ib, &a[i__ dlarfb_(side, transt, (char *)"Forward", (char *)"Rowwise", &mi, &ni, &ib, &a[i__
+ i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc * + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc *
c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, ( c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (
ftnlen)7, (ftnlen)7); ftnlen)7, (ftnlen)7);
/* L10: */ /* L10: */
} }
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
@ -420,5 +420,5 @@ f"> */
} /* dormlq_ */ } /* dormlq_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

198
lib/linalg/dormql.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dormql.f -- translated by f2c (version 20200916). /* fortran/dormql.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -189,15 +189,15 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n, /* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info, c__, integer *ldc, doublereal *work, integer *lwork, integer *info,
ftnlen side_len, ftnlen trans_len) ftnlen side_len, ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
address a__1[2]; address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5; i__5;
char ch__1[2]; char ch__1[2];
/* Builtin functions */ /* Builtin functions */
@ -208,17 +208,17 @@ f"> */
logical left; logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nbmin, iinfo; integer nbmin, iinfo;
extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *, extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char
*, char *, char *, char *, integer *, integer *, integer *, *, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen, *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
logical notran; logical notran;
integer ldwork, lwkopt; integer ldwork, lwkopt;
logical lquery; logical lquery;
@ -268,141 +268,141 @@ f"> */
/* NQ is the order of Q and NW is the minimum dimension of WORK */ /* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) { if (left) {
nq = *m; nq = *m;
nw = max(1,*n); nw = max(1,*n);
} else { } else {
nq = *n; nq = *n;
nw = max(1,*m); nw = max(1,*m);
} }
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (*m < 0) { } else if (*m < 0) {
*info = -3; *info = -3;
} else if (*n < 0) { } else if (*n < 0) {
*info = -4; *info = -4;
} else if (*k < 0 || *k > nq) { } else if (*k < 0 || *k > nq) {
*info = -5; *info = -5;
} else if (*lda < max(1,nq)) { } else if (*lda < max(1,nq)) {
*info = -7; *info = -7;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -10; *info = -10;
} else if (*lwork < nw && ! lquery) { } else if (*lwork < nw && ! lquery) {
*info = -12; *info = -12;
} }
if (*info == 0) { if (*info == 0) {
/* Compute the workspace requirements */ /* Compute the workspace requirements */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
lwkopt = 1; lwkopt = 1;
} else { } else {
/* Computing MIN */ /* Computing MIN */
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, n, k, &c_n1, i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, n, k, &c_n1,
(ftnlen)6, (ftnlen)2); (ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2); nb = min(i__1,i__2);
lwkopt = nw * nb + 4160; lwkopt = nw * nb + 4160;
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORMQL", &i__1, (ftnlen)6); xerbla_((char *)"DORMQL", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0) { if (*m == 0 || *n == 0) {
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
ldwork = nw; ldwork = nw;
if (nb > 1 && nb < *k) { if (nb > 1 && nb < *k) {
if (*lwork < lwkopt) { if (*lwork < lwkopt) {
nb = (*lwork - 4160) / ldwork; nb = (*lwork - 4160) / ldwork;
/* Computing MAX */ /* Computing MAX */
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQL", ch__1, m, n, k, &c_n1, ( i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQL", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
if (nb < nbmin || nb >= *k) { if (nb < nbmin || nb >= *k) {
/* Use unblocked code */ /* Use unblocked code */
dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1);
} else { } else {
/* Use blocked code */ /* Use blocked code */
iwt = nw * nb + 1; iwt = nw * nb + 1;
if (left && notran || ! left && ! notran) { if (left && notran || ! left && ! notran) {
i1 = 1; i1 = 1;
i2 = *k; i2 = *k;
i3 = nb; i3 = nb;
} else { } else {
i1 = (*k - 1) / nb * nb + 1; i1 = (*k - 1) / nb * nb + 1;
i2 = 1; i2 = 1;
i3 = -nb; i3 = -nb;
} }
if (left) { if (left) {
ni = *n; ni = *n;
} else { } else {
mi = *m; mi = *m;
} }
i__1 = i2; i__1 = i2;
i__2 = i3; i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */ /* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1; i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5); ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i+ib-1) . . . H(i+1) H(i) */ /* H = H(i+ib-1) . . . H(i+1) H(i) */
i__4 = nq - *k + i__ + ib - 1; i__4 = nq - *k + i__ + ib - 1;
dlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] dlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
, lda, &tau[i__], &work[iwt], &c__65, (ftnlen)8, (ftnlen) , lda, &tau[i__], &work[iwt], &c__65, (ftnlen)8, (ftnlen)
10); 10);
if (left) { if (left) {
/* H or H**T is applied to C(1:m-k+i+ib-1,1:n) */ /* H or H**T is applied to C(1:m-k+i+ib-1,1:n) */
mi = *m - *k + i__ + ib - 1; mi = *m - *k + i__ + ib - 1;
} else { } else {
/* H or H**T is applied to C(1:m,1:n-k+i+ib-1) */ /* H or H**T is applied to C(1:m,1:n-k+i+ib-1) */
ni = *n - *k + i__ + ib - 1; ni = *n - *k + i__ + ib - 1;
} }
/* Apply H or H**T */ /* Apply H or H**T */
dlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[ dlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[
i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset] i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset]
, ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (ftnlen)8, , ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (ftnlen)8,
(ftnlen)10); (ftnlen)10);
/* L10: */ /* L10: */
} }
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
@ -412,5 +412,5 @@ f"> */
} /* dormql_ */ } /* dormql_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

200
lib/linalg/dormqr.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dormqr.f -- translated by f2c (version 20200916). /* fortran/dormqr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -189,15 +189,15 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, /* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info, c__, integer *ldc, doublereal *work, integer *lwork, integer *info,
ftnlen side_len, ftnlen trans_len) ftnlen side_len, ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
address a__1[2]; address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5; i__5;
char ch__1[2]; char ch__1[2];
/* Builtin functions */ /* Builtin functions */
@ -208,17 +208,17 @@ f"> */
logical left; logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nbmin, iinfo; integer nbmin, iinfo;
extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char
*, char *, char *, char *, integer *, integer *, integer *, *, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen, *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen); ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
logical notran; logical notran;
integer ldwork, lwkopt; integer ldwork, lwkopt;
logical lquery; logical lquery;
@ -268,28 +268,28 @@ f"> */
/* NQ is the order of Q and NW is the minimum dimension of WORK */ /* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) { if (left) {
nq = *m; nq = *m;
nw = max(1,*n); nw = max(1,*n);
} else { } else {
nq = *n; nq = *n;
nw = max(1,*m); nw = max(1,*m);
} }
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (*m < 0) { } else if (*m < 0) {
*info = -3; *info = -3;
} else if (*n < 0) { } else if (*n < 0) {
*info = -4; *info = -4;
} else if (*k < 0 || *k > nq) { } else if (*k < 0 || *k > nq) {
*info = -5; *info = -5;
} else if (*lda < max(1,nq)) { } else if (*lda < max(1,nq)) {
*info = -7; *info = -7;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -10; *info = -10;
} else if (*lwork < nw && ! lquery) { } else if (*lwork < nw && ! lquery) {
*info = -12; *info = -12;
} }
if (*info == 0) { if (*info == 0) {
@ -298,112 +298,112 @@ f"> */
/* Computing MIN */ /* Computing MIN */
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, n, k, &c_n1, ( i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2); nb = min(i__1,i__2);
lwkopt = nw * nb + 4160; lwkopt = nw * nb + 4160;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DORMQR", &i__1, (ftnlen)6); xerbla_((char *)"DORMQR", &i__1, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) { if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
nbmin = 2; nbmin = 2;
ldwork = nw; ldwork = nw;
if (nb > 1 && nb < *k) { if (nb > 1 && nb < *k) {
if (*lwork < lwkopt) { if (*lwork < lwkopt) {
nb = (*lwork - 4160) / ldwork; nb = (*lwork - 4160) / ldwork;
/* Computing MAX */ /* Computing MAX */
/* Writing concatenation */ /* Writing concatenation */
i__3[0] = 1, a__1[0] = side; i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans; i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQR", ch__1, m, n, k, &c_n1, ( i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQR", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2); nbmin = max(i__1,i__2);
} }
} }
if (nb < nbmin || nb >= *k) { if (nb < nbmin || nb >= *k) {
/* Use unblocked code */ /* Use unblocked code */
dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1);
} else { } else {
/* Use blocked code */ /* Use blocked code */
iwt = nw * nb + 1; iwt = nw * nb + 1;
if (left && ! notran || ! left && notran) { if (left && ! notran || ! left && notran) {
i1 = 1; i1 = 1;
i2 = *k; i2 = *k;
i3 = nb; i3 = nb;
} else { } else {
i1 = (*k - 1) / nb * nb + 1; i1 = (*k - 1) / nb * nb + 1;
i2 = 1; i2 = 1;
i3 = -nb; i3 = -nb;
} }
if (left) { if (left) {
ni = *n; ni = *n;
jc = 1; jc = 1;
} else { } else {
mi = *m; mi = *m;
ic = 1; ic = 1;
} }
i__1 = i2; i__1 = i2;
i__2 = i3; i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */ /* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1; i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5); ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */ /* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */ /* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1; i__4 = nq - i__ + 1;
dlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ * dlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, ( a_dim1], lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, (
ftnlen)10); ftnlen)10);
if (left) { if (left) {
/* H or H**T is applied to C(i:m,1:n) */ /* H or H**T is applied to C(i:m,1:n) */
mi = *m - i__ + 1; mi = *m - i__ + 1;
ic = i__; ic = i__;
} else { } else {
/* H or H**T is applied to C(1:m,i:n) */ /* H or H**T is applied to C(1:m,i:n) */
ni = *n - i__ + 1; ni = *n - i__ + 1;
jc = i__; jc = i__;
} }
/* Apply H or H**T */ /* Apply H or H**T */
dlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[ dlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[
i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic +
jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen) jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)
1, (ftnlen)7, (ftnlen)10); 1, (ftnlen)7, (ftnlen)10);
/* L10: */ /* L10: */
} }
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
@ -413,5 +413,5 @@ f"> */
} /* dormqr_ */ } /* dormqr_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

196
lib/linalg/dormtr.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dormtr.f -- translated by f2c (version 20200916). /* fortran/dormtr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -192,10 +192,10 @@ f"> */
/* > \ingroup doubleOTHERcomputational */ /* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m, /* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m,
integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal * integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info, c__, integer *ldc, doublereal *work, integer *lwork, integer *info,
ftnlen side_len, ftnlen uplo_len, ftnlen trans_len) ftnlen side_len, ftnlen uplo_len, ftnlen trans_len)
{ {
/* System generated locals */ /* System generated locals */
address a__1[2]; address a__1[2];
@ -212,14 +212,14 @@ f"> */
integer iinfo; integer iinfo;
logical upper; logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen); integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dormql_(char *, char *, integer *, integer *, extern /* Subroutine */ int dormql_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen), integer *, doublereal *, integer *, integer *, ftnlen, ftnlen),
dormqr_(char *, char *, integer *, integer *, integer *, dormqr_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, ftnlen, ftnlen); doublereal *, integer *, integer *, ftnlen, ftnlen);
integer lwkopt; integer lwkopt;
logical lquery; logical lquery;
@ -266,123 +266,123 @@ f"> */
/* NQ is the order of Q and NW is the minimum dimension of WORK */ /* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) { if (left) {
nq = *m; nq = *m;
nw = max(1,*n); nw = max(1,*n);
} else { } else {
nq = *n; nq = *n;
nw = max(1,*m); nw = max(1,*m);
} }
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -2; *info = -2;
} else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
(char *)"T", (ftnlen)1, (ftnlen)1)) { (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -3; *info = -3;
} else if (*m < 0) { } else if (*m < 0) {
*info = -4; *info = -4;
} else if (*n < 0) { } else if (*n < 0) {
*info = -5; *info = -5;
} else if (*lda < max(1,nq)) { } else if (*lda < max(1,nq)) {
*info = -7; *info = -7;
} else if (*ldc < max(1,*m)) { } else if (*ldc < max(1,*m)) {
*info = -10; *info = -10;
} else if (*lwork < nw && ! lquery) { } else if (*lwork < nw && ! lquery) {
*info = -12; *info = -12;
} }
if (*info == 0) { if (*info == 0) {
if (upper) { if (upper) {
if (left) { if (left) {
/* Writing concatenation */ /* Writing concatenation */
i__1[0] = 1, a__1[0] = side; i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans; i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *m - 1; i__2 = *m - 1;
i__3 = *m - 1; i__3 = *m - 1;
nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, &i__2, n, &i__3, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, &i__2, n, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} else { } else {
/* Writing concatenation */ /* Writing concatenation */
i__1[0] = 1, a__1[0] = side; i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans; i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, &i__2, &i__3, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} }
} else { } else {
if (left) { if (left) {
/* Writing concatenation */ /* Writing concatenation */
i__1[0] = 1, a__1[0] = side; i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans; i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *m - 1; i__2 = *m - 1;
i__3 = *m - 1; i__3 = *m - 1;
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__2, n, &i__3, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__2, n, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} else { } else {
/* Writing concatenation */ /* Writing concatenation */
i__1[0] = 1, a__1[0] = side; i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans; i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *n - 1; i__2 = *n - 1;
i__3 = *n - 1; i__3 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__2, &i__3, &c_n1, ( nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2); ftnlen)6, (ftnlen)2);
} }
} }
lwkopt = nw * nb; lwkopt = nw * nb;
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
} }
if (*info != 0) { if (*info != 0) {
i__2 = -(*info); i__2 = -(*info);
xerbla_((char *)"DORMTR", &i__2, (ftnlen)6); xerbla_((char *)"DORMTR", &i__2, (ftnlen)6);
return 0; return 0;
} else if (lquery) { } else if (lquery) {
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*m == 0 || *n == 0 || nq == 1) { if (*m == 0 || *n == 0 || nq == 1) {
work[1] = 1.; work[1] = 1.;
return 0; return 0;
} }
if (left) { if (left) {
mi = *m - 1; mi = *m - 1;
ni = *n; ni = *n;
} else { } else {
mi = *m; mi = *m;
ni = *n - 1; ni = *n - 1;
} }
if (upper) { if (upper) {
/* Q was determined by a call to DSYTRD with UPLO = 'U' */ /* Q was determined by a call to DSYTRD with UPLO = 'U' */
i__2 = nq - 1; i__2 = nq - 1;
dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen) tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)
1, (ftnlen)1); 1, (ftnlen)1);
} else { } else {
/* Q was determined by a call to DSYTRD with UPLO = 'L' */ /* Q was determined by a call to DSYTRD with UPLO = 'L' */
if (left) { if (left) {
i1 = 2; i1 = 2;
i2 = 1; i2 = 1;
} else { } else {
i1 = 1; i1 = 1;
i2 = 2; i2 = 2;
} }
i__2 = nq - 1; i__2 = nq - 1;
dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen) c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen)
1, (ftnlen)1); 1, (ftnlen)1);
} }
work[1] = (doublereal) lwkopt; work[1] = (doublereal) lwkopt;
return 0; return 0;
@ -392,5 +392,5 @@ f"> */
} /* dormtr_ */ } /* dormtr_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

50
lib/linalg/dposv.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dposv.f -- translated by f2c (version 20200916). /* fortran/dposv.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -146,9 +146,9 @@ extern "C" {
/* > \ingroup doublePOsolve */ /* > \ingroup doublePOsolve */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal /* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal
*a, integer *lda, doublereal *b, integer *ldb, integer *info, ftnlen *a, integer *lda, doublereal *b, integer *ldb, integer *info, ftnlen
uplo_len) uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1; integer a_dim1, a_offset, b_dim1, b_offset, i__1;
@ -156,9 +156,9 @@ extern "C" {
/* Local variables */ /* Local variables */
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpotrf_( extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpotrf_(
char *, integer *, doublereal *, integer *, integer *, ftnlen), char *, integer *, doublereal *, integer *, integer *, ftnlen),
dpotrs_(char *, integer *, integer *, doublereal *, integer *, dpotrs_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, ftnlen); doublereal *, integer *, integer *, ftnlen);
/* -- LAPACK driver routine -- */ /* -- LAPACK driver routine -- */
@ -193,21 +193,21 @@ extern "C" {
/* Function Body */ /* Function Body */
*info = 0; *info = 0;
if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", (
ftnlen)1, (ftnlen)1)) { ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*nrhs < 0) { } else if (*nrhs < 0) {
*info = -3; *info = -3;
} else if (*lda < max(1,*n)) { } else if (*lda < max(1,*n)) {
*info = -5; *info = -5;
} else if (*ldb < max(1,*n)) { } else if (*ldb < max(1,*n)) {
*info = -7; *info = -7;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DPOSV ", &i__1, (ftnlen)6); xerbla_((char *)"DPOSV ", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Compute the Cholesky factorization A = U**T*U or A = L*L**T. */ /* Compute the Cholesky factorization A = U**T*U or A = L*L**T. */
@ -217,8 +217,8 @@ extern "C" {
/* Solve the system A*X = B, overwriting B with X. */ /* Solve the system A*X = B, overwriting B with X. */
dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info, ( dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info, (
ftnlen)1); ftnlen)1);
} }
return 0; return 0;
@ -228,5 +228,5 @@ extern "C" {
} /* dposv_ */ } /* dposv_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

134
lib/linalg/dpotf2.cpp
View File

@ -1,13 +1,13 @@
/* fortran/dpotf2.f -- translated by f2c (version 20200916). /* fortran/dpotf2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#ifdef __cplusplus #ifdef __cplusplus
@ -133,7 +133,7 @@ f"> */
/* ===================================================================== */ /* ===================================================================== */
/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer * /* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *info, ftnlen uplo_len) lda, integer *info, ftnlen uplo_len)
{ {
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3; integer a_dim1, a_offset, i__1, i__2, i__3;
@ -145,14 +145,14 @@ f"> */
/* Local variables */ /* Local variables */
integer j; integer j;
doublereal ajj; doublereal ajj;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *); integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *); integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *, extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen); doublereal *, doublereal *, integer *, ftnlen);
logical upper; logical upper;
extern logical disnan_(doublereal *); extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
@ -192,90 +192,90 @@ f"> */
*info = 0; *info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1; *info = -1;
} else if (*n < 0) { } else if (*n < 0) {
*info = -2; *info = -2;
} else if (*lda < max(1,*n)) { } else if (*lda < max(1,*n)) {
*info = -4; *info = -4;
} }
if (*info != 0) { if (*info != 0) {
i__1 = -(*info); i__1 = -(*info);
xerbla_((char *)"DPOTF2", &i__1, (ftnlen)6); xerbla_((char *)"DPOTF2", &i__1, (ftnlen)6);
return 0; return 0;
} }
/* Quick return if possible */ /* Quick return if possible */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
} }
if (upper) { if (upper) {
/* Compute the Cholesky factorization A = U**T *U. */ /* Compute the Cholesky factorization A = U**T *U. */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */ /* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = j - 1; i__2 = j - 1;
ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1,
&a[j * a_dim1 + 1], &c__1); &a[j * a_dim1 + 1], &c__1);
if (ajj <= 0. || disnan_(&ajj)) { if (ajj <= 0. || disnan_(&ajj)) {
a[j + j * a_dim1] = ajj; a[j + j * a_dim1] = ajj;
goto L30; goto L30;
} }
ajj = sqrt(ajj); ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj; a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J. */ /* Compute elements J+1:N of row J. */
if (j < *n) { if (j < *n) {
i__2 = j - 1; i__2 = j - 1;
i__3 = *n - j; i__3 = *n - j;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 dgemv_((char *)"Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1
+ 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + (
j + 1) * a_dim1], lda, (ftnlen)9); j + 1) * a_dim1], lda, (ftnlen)9);
i__2 = *n - j; i__2 = *n - j;
d__1 = 1. / ajj; d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
} }
/* L10: */ /* L10: */
} }
} else { } else {
/* Compute the Cholesky factorization A = L*L**T. */ /* Compute the Cholesky factorization A = L*L**T. */
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */ /* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j - 1; i__2 = j - 1;
ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j
+ a_dim1], lda); + a_dim1], lda);
if (ajj <= 0. || disnan_(&ajj)) { if (ajj <= 0. || disnan_(&ajj)) {
a[j + j * a_dim1] = ajj; a[j + j * a_dim1] = ajj;
goto L30; goto L30;
} }
ajj = sqrt(ajj); ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj; a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J. */ /* Compute elements J+1:N of column J. */
if (j < *n) { if (j < *n) {
i__2 = *n - j; i__2 = *n - j;
i__3 = j - 1; i__3 = j - 1;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b10, &a[j + 1 +
a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 +
j * a_dim1], &c__1, (ftnlen)12); j * a_dim1], &c__1, (ftnlen)12);
i__2 = *n - j; i__2 = *n - j;
d__1 = 1. / ajj; d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
} }
/* L20: */ /* L20: */
} }
} }
goto L40; goto L40;
@ -290,5 +290,5 @@ L40:
} /* dpotf2_ */ } /* dpotf2_ */
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

Some files were not shown because too many files have changed in this diff Show More