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

remove redundant comments from generated C++ files. clean up with clang-format.

Browse Source
This commit is contained in:
Axel Kohlmeyer
2022-12-28 16:31:50 -05:00
parent f157ba2389
commit 57713cf9a3
211 changed files with 6255 additions and 54891 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
lib/linalg/convert.sh
View File

@ -21,12 +21,15 @@ do \
then
echo Skipping $b
else
# convert to C++ with f2c. Make local variables dynamic.
f2c -C++ -a -f $f && mv $b.c $b.cpp || exit 2
# silence c++ compiler warnings about string constants
# convert to C++ with f2c, make local variables dynamic,
# strip comments, and reindent with clang-format.
f2c -C++ -a -f < $f \
| g++ -fpreprocessed -dD -P -E - \
| clang-format -style=file:static/.clang-format > $b.cpp || exit 2
# silence c++ compiler warnings about string constants, use custom f2c header
sed -i -e 's/\("[^"]\+"\)/(char *)\1/g' -e 's/^extern.*"C"/extern "C"/' \
-e 's/^#include.*"f2c.h"/#include "lmp_f2c.h"/' $b.cpp
# replace libf2c functions with local versions under a different name
# replace libf2c functions with local versions under different names
sed -i -e 's/s_\(cat\|cmp\|copy\)(/s_lmp_\1(/g' \
-e 's/d_\(sign\|cnjg\|imag\|lg10\)(/d_lmp_\1(/g' \
-e 's/z_\(abs\|div\)(/z_lmp_\1(/g' \
@ -39,12 +42,15 @@ done
for f in static/*.f
do \
b=$(basename $f .f)
# convert to C++ with f2c. Make local variables dynamic.
f2c -C++ -a -f $f && mv $b.c $b.cpp || exit 2
# silence c++ compiler warnings about string constants
# convert to C++ with f2c, make local variables dynamic,
# strip comments, and reindent with clang-format.
f2c -C++ -a -f < $f \
| g++ -fpreprocessed -dD -P -E - \
| clang-format -style=file:static/.clang-format > $b.cpp || exit 2
# silence c++ compiler warnings about string constants, use custom f2c header
sed -i -e 's/\("[^"]\+"\)/(char *)\1/g' -e 's/^extern.*"C"/extern "C"/' \
-e 's/^#include.*"f2c.h"/#include "lmp_f2c.h"/' $b.cpp
# replace libf2c functions with local versions under a different name
# replace libf2c functions with local versions under different names
sed -i -e 's/s_\(cat\|cmp\|copy\)(/s_lmp_\1(/g' \
-e 's/d_\(sign\|cnjg\|imag\|lg10\)(/d_lmp_\1(/g' \
-e 's/z_\(abs\|div\)(/z_lmp_\1(/g' \
@ -57,6 +63,3 @@ for c in static/*.cpp
do \
cp -v $c .
done
# fix whitespace
python ../../tools/coding_standard/whitespace.py -c whitespace.conf -f .

128
lib/linalg/dasum.cpp
View File

@ -1,131 +1,21 @@
/* fortran/dasum.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DASUM */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) */
/* .. Scalar Arguments .. */
/* INTEGER INCX,N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION DX(*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DASUM takes the sum of the absolute values. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > number of elements in input vector(s) */
/* > \endverbatim */
/* > */
/* > \param[in] DX */
/* > \verbatim */
/* > DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > storage spacing between elements of DX */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level1 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > jack dongarra, linpack, 3/11/78. */
/* > modified 3/93 to return if incx .le. 0. */
/* > modified 12/3/93, array(1) declarations changed to array(*) */
/* > \endverbatim */
/* > */
/* ===================================================================== */
doublereal dasum_(integer *n, doublereal *dx, integer *incx)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
integer i__, m, mp1;
doublereal dtemp;
integer nincx;
/* -- Reference BLAS level1 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Parameter adjustments */
--dx;
/* Function Body */
ret_val = 0.;
dtemp = 0.;
if (*n <= 0 || *incx <= 0) {
return ret_val;
}
if (*incx == 1) {
/* code for increment equal to 1 */
/* clean-up loop */
m = *n % 6;
if (m != 0) {
i__1 = m;
@ -140,15 +30,11 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx)
mp1 = m + 1;
i__1 = *n;
for (i__ = mp1; i__ <= i__1; i__ += 6) {
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 =
dx[i__ + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5))
+ (d__6 = dx[i__ + 5], abs(d__6));
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 = dx[i__ + 3], abs(d__4)) +
(d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = dx[i__ + 5], abs(d__6));
}
} else {
/* code for increment not equal to 1 */
nincx = *n * *incx;
i__1 = nincx;
i__2 = *incx;
@ -158,11 +44,7 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx)
}
ret_val = dtemp;
return ret_val;
/* End of DASUM */
} /* dasum_ */
}
#ifdef __cplusplus
}
}
#endif

144
lib/linalg/daxpy.cpp
View File

@ -1,137 +1,13 @@
/* fortran/daxpy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DAXPY */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION DA */
/* INTEGER INCX,INCY,N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION DX(*),DY(*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DAXPY constant times a vector plus a vector. */
/* > uses unrolled loops for increments equal to one. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > number of elements in input vector(s) */
/* > \endverbatim */
/* > */
/* > \param[in] DA */
/* > \verbatim */
/* > DA is DOUBLE PRECISION */
/* > On entry, DA specifies the scalar alpha. */
/* > \endverbatim */
/* > */
/* > \param[in] DX */
/* > \verbatim */
/* > DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > storage spacing between elements of DX */
/* > \endverbatim */
/* > */
/* > \param[in,out] DY */
/* > \verbatim */
/* > DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCY */
/* > \verbatim */
/* > INCY is INTEGER */
/* > storage spacing between elements of DY */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level1 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > jack dongarra, linpack, 3/11/78. */
/* > modified 12/3/93, array(1) declarations changed to array(*) */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx,
integer *incx, doublereal *dy, integer *incy)
int daxpy_(integer *n, doublereal *da, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, m, ix, iy, mp1;
/* -- Reference BLAS level1 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Parameter adjustments */
--dy;
--dx;
/* Function Body */
if (*n <= 0) {
return 0;
}
@ -139,12 +15,6 @@ extern "C" {
return 0;
}
if (*incx == 1 && *incy == 1) {
/* code for both increments equal to 1 */
/* clean-up loop */
m = *n % 4;
if (m != 0) {
i__1 = m;
@ -164,10 +34,6 @@ extern "C" {
dy[i__ + 3] += *da * dx[i__ + 3];
}
} else {
/* code for unequal increments or equal increments */
/* not equal to 1 */
ix = 1;
iy = 1;
if (*incx < 0) {
@ -184,11 +50,7 @@ extern "C" {
}
}
return 0;
/* End of DAXPY */
} /* daxpy_ */
}
#ifdef __cplusplus
}
}
#endif

699
lib/linalg/dbdsqr.cpp
View File

File diff suppressed because it is too large Load Diff

82
lib/linalg/dcabs1.cpp
View File

@ -1,92 +1,14 @@
/* fortran/dcabs1.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DCABS1 */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DCABS1(Z) */
/* .. Scalar Arguments .. */
/* COMPLEX*16 Z */
/* .. */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DCABS1 computes |Re(.)| + |Im(.)| of a double complex number */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is COMPLEX*16 */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level1 */
/* ===================================================================== */
doublereal dcabs1_(doublecomplex *z__)
{
/* System generated locals */
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double d_lmp_imag(doublecomplex *);
/* -- Reference BLAS level1 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. */
/* ===================================================================== */
/* .. Intrinsic Functions .. */
ret_val = (d__1 = z__->r, abs(d__1)) + (d__2 = d_lmp_imag(z__), abs(d__2));
return ret_val;
/* End of DCABS1 */
} /* dcabs1_ */
}
#ifdef __cplusplus
}
}
#endif

137
lib/linalg/dcopy.cpp
View File

@ -1,140 +1,17 @@
/* fortran/dcopy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DCOPY */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) */
/* .. Scalar Arguments .. */
/* INTEGER INCX,INCY,N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION DX(*),DY(*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DCOPY copies a vector, x, to a vector, y. */
/* > uses unrolled loops for increments equal to 1. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > number of elements in input vector(s) */
/* > \endverbatim */
/* > */
/* > \param[in] DX */
/* > \verbatim */
/* > DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > storage spacing between elements of DX */
/* > \endverbatim */
/* > */
/* > \param[out] DY */
/* > \verbatim */
/* > DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCY */
/* > \verbatim */
/* > INCY is INTEGER */
/* > storage spacing between elements of DY */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level1 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > jack dongarra, linpack, 3/11/78. */
/* > modified 12/3/93, array(1) declarations changed to array(*) */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx,
doublereal *dy, integer *incy)
int dcopy_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, m, ix, iy, mp1;
/* -- Reference BLAS level1 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Parameter adjustments */
--dy;
--dx;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (*incx == 1 && *incy == 1) {
/* code for both increments equal to 1 */
/* clean-up loop */
m = *n % 7;
if (m != 0) {
i__1 = m;
@ -157,10 +34,6 @@ extern "C" {
dy[i__ + 6] = dx[i__ + 6];
}
} else {
/* code for unequal increments or equal increments */
/* not equal to 1 */
ix = 1;
iy = 1;
if (*incx < 0) {
@ -177,11 +50,7 @@ extern "C" {
}
}
return 0;
/* End of DCOPY */
} /* dcopy_ */
}
#ifdef __cplusplus
}
}
#endif

137
lib/linalg/ddot.cpp
View File

@ -1,144 +1,21 @@
/* fortran/ddot.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DDOT */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) */
/* .. Scalar Arguments .. */
/* INTEGER INCX,INCY,N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION DX(*),DY(*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DDOT forms the dot product of two vectors. */
/* > uses unrolled loops for increments equal to one. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > number of elements in input vector(s) */
/* > \endverbatim */
/* > */
/* > \param[in] DX */
/* > \verbatim */
/* > DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > storage spacing between elements of DX */
/* > \endverbatim */
/* > */
/* > \param[in] DY */
/* > \verbatim */
/* > DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCY */
/* > \verbatim */
/* > INCY is INTEGER */
/* > storage spacing between elements of DY */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level1 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > jack dongarra, linpack, 3/11/78. */
/* > modified 12/3/93, array(1) declarations changed to array(*) */
/* > \endverbatim */
/* > */
/* ===================================================================== */
doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
integer *incy)
doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
{
/* System generated locals */
integer i__1;
doublereal ret_val;
/* Local variables */
integer i__, m, ix, iy, mp1;
doublereal dtemp;
/* -- Reference BLAS level1 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Parameter adjustments */
--dy;
--dx;
/* Function Body */
ret_val = 0.;
dtemp = 0.;
if (*n <= 0) {
return ret_val;
}
if (*incx == 1 && *incy == 1) {
/* code for both increments equal to 1 */
/* clean-up loop */
m = *n % 5;
if (m != 0) {
i__1 = m;
@ -158,10 +35,6 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
dx[i__ + 4] * dy[i__ + 4];
}
} else {
/* code for unequal increments or equal increments */
/* not equal to 1 */
ix = 1;
iy = 1;
if (*incx < 0) {
@ -179,11 +52,7 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
}
ret_val = dtemp;
return ret_val;
/* End of DDOT */
} /* ddot_ */
}
#ifdef __cplusplus
}
}
#endif

338
lib/linalg/dgebd2.cpp
View File

@ -1,254 +1,17 @@
/* fortran/dgebd2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGEBD2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgebd2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgebd2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgebd2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), */
/* $ TAUQ( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGEBD2 reduces a real general m by n matrix A to upper or lower */
/* > bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */
/* > */
/* > If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows in the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns in the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the m by n general matrix to be reduced. */
/* > On exit, */
/* > if m >= n, the diagonal and the first superdiagonal are */
/* > overwritten with the upper bidiagonal matrix B; the */
/* > elements below the diagonal, with the array TAUQ, represent */
/* > the orthogonal matrix Q as a product of elementary */
/* > reflectors, and the elements above the first superdiagonal, */
/* > with the array TAUP, represent the orthogonal matrix P as */
/* > a product of elementary reflectors; */
/* > if m < n, the diagonal and the first subdiagonal are */
/* > overwritten with the lower bidiagonal matrix B; the */
/* > elements below the first subdiagonal, with the array TAUQ, */
/* > represent the orthogonal matrix Q as a product of */
/* > elementary reflectors, and the elements above the diagonal, */
/* > with the array TAUP, represent the orthogonal matrix P as */
/* > a product of elementary reflectors. */
/* > See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The diagonal elements of the bidiagonal matrix B: */
/* > D(i) = A(i,i). */
/* > \endverbatim */
/* > */
/* > \param[out] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (min(M,N)-1) */
/* > The off-diagonal elements of the bidiagonal matrix B: */
/* > if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* > if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* > \endverbatim */
/* > */
/* > \param[out] TAUQ */
/* > \verbatim */
/* > TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors which */
/* > represent the orthogonal matrix Q. See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[out] TAUP */
/* > \verbatim */
/* > TAUP is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors which */
/* > represent the orthogonal matrix P. See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (max(M,N)) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The matrices Q and P are represented as products of elementary */
/* > reflectors: */
/* > */
/* > If m >= n, */
/* > */
/* > Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
/* > */
/* > Each H(i) and G(i) has the form: */
/* > */
/* > H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T */
/* > */
/* > where tauq and taup are real scalars, and v and u are real vectors; */
/* > v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
/* > u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
/* > tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* > */
/* > If m < n, */
/* > */
/* > Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
/* > */
/* > Each H(i) and G(i) has the form: */
/* > */
/* > H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T */
/* > */
/* > where tauq and taup are real scalars, and v and u are real vectors; */
/* > v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
/* > u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
/* > tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* > */
/* > The contents of A on exit are illustrated by the following examples: */
/* > */
/* > m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* > */
/* > ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
/* > ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
/* > ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
/* > ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
/* > ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
/* > ( v1 v2 v3 v4 v5 ) */
/* > */
/* > where d and e denote diagonal and off-diagonal elements of B, vi */
/* > denotes an element of the vector defining H(i), and ui an element of */
/* > the vector defining G(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
taup, doublereal *work, integer *info)
int dgebd2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *d__, doublereal *e,
doublereal *tauq, doublereal *taup, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -257,14 +20,12 @@ f"> */
--tauq;
--taup;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info < 0) {
@ -272,122 +33,73 @@ f"> */
xerbla_((char *)"DGEBD2", &i__1, (ftnlen)6);
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ *
a_dim1], &c__1, &tauq[i__]);
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1,
&tauq[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
/* Apply H(i) to A(i:m,i+1:n) from the left */
if (i__ < *n) {
i__2 = *m - i__ + 1;
i__3 = *n - i__;
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]
, (ftnlen)4);
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], (ftnlen)4);
}
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihilate */
/* A(i,i+2:n) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
i__3,*n) * a_dim1], lda, &taup[i__]);
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda,
&taup[i__]);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1], (ftnlen)5);
dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &taup[i__],
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)5);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
} else {
taup[i__] = 0.;
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) *
a_dim1], lda, &taup[i__]);
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda,
&taup[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
/* Apply G(i) to A(i+1:m,i:n) from the right */
if (i__ < *m) {
i__2 = *m - i__;
i__3 = *n - i__ + 1;
dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1],
(ftnlen)5);
dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &taup[i__],
&a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)5);
}
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:m,i) */
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) +
i__ * a_dim1], &c__1, &tauq[i__]);
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1,
&tauq[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Apply H(i) to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1], (ftnlen)4);
dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tauq[i__],
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4);
a[i__ + 1 + i__ * a_dim1] = e[i__];
} else {
tauq[i__] = 0.;
}
/* L20: */
}
}
return 0;
/* End of DGEBD2 */
} /* dgebd2_ */
}
#ifdef __cplusplus
}
}
#endif

378
lib/linalg/dgebrd.cpp
View File

@ -1,285 +1,32 @@
/* fortran/dgebrd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
static doublereal c_b21 = -1.;
static doublereal c_b22 = 1.;
/* > \brief \b DGEBRD */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGEBRD + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgebrd.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgebrd.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgebrd.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, */
/* INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), */
/* $ TAUQ( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGEBRD reduces a general real M-by-N matrix A to upper or lower */
/* > bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */
/* > */
/* > If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows in the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns in the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the M-by-N general matrix to be reduced. */
/* > On exit, */
/* > if m >= n, the diagonal and the first superdiagonal are */
/* > overwritten with the upper bidiagonal matrix B; the */
/* > elements below the diagonal, with the array TAUQ, represent */
/* > the orthogonal matrix Q as a product of elementary */
/* > reflectors, and the elements above the first superdiagonal, */
/* > with the array TAUP, represent the orthogonal matrix P as */
/* > a product of elementary reflectors; */
/* > if m < n, the diagonal and the first subdiagonal are */
/* > overwritten with the lower bidiagonal matrix B; the */
/* > elements below the first subdiagonal, with the array TAUQ, */
/* > represent the orthogonal matrix Q as a product of */
/* > elementary reflectors, and the elements above the diagonal, */
/* > with the array TAUP, represent the orthogonal matrix P as */
/* > a product of elementary reflectors. */
/* > See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The diagonal elements of the bidiagonal matrix B: */
/* > D(i) = A(i,i). */
/* > \endverbatim */
/* > */
/* > \param[out] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (min(M,N)-1) */
/* > The off-diagonal elements of the bidiagonal matrix B: */
/* > if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* > if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* > \endverbatim */
/* > */
/* > \param[out] TAUQ */
/* > \verbatim */
/* > TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors which */
/* > represent the orthogonal matrix Q. See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[out] TAUP */
/* > \verbatim */
/* > TAUP is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors which */
/* > represent the orthogonal matrix P. See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The length of the array WORK. LWORK >= max(1,M,N). */
/* > For optimum performance LWORK >= (M+N)*NB, where NB */
/* > is the optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The matrices Q and P are represented as products of elementary */
/* > reflectors: */
/* > */
/* > If m >= n, */
/* > */
/* > Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
/* > */
/* > Each H(i) and G(i) has the form: */
/* > */
/* > H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T */
/* > */
/* > where tauq and taup are real scalars, and v and u are real vectors; */
/* > v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
/* > u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
/* > tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* > */
/* > If m < n, */
/* > */
/* > Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
/* > */
/* > Each H(i) and G(i) has the form: */
/* > */
/* > H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T */
/* > */
/* > where tauq and taup are real scalars, and v and u are real vectors; */
/* > v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
/* > u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
/* > tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* > */
/* > The contents of A on exit are illustrated by the following examples: */
/* > */
/* > m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* > */
/* > ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
/* > ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
/* > ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
/* > ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
/* > ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
/* > ( v1 v2 v3 v4 v5 ) */
/* > */
/* > where d and e denote diagonal and off-diagonal elements of B, vi */
/* > denotes an element of the vector defining H(i), and ui an element of */
/* > the vector defining G(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
taup, doublereal *work, integer *lwork, integer *info)
int dgebrd_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *d__, doublereal *e,
doublereal *tauq, doublereal *taup, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, j, nb, nx, ws;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer nbmin, iinfo, minmn;
extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlabrd_(integer *, integer *, integer *
, doublereal *, integer *, doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
, xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dgebd2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *),
dlabrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwrkx, ldwrky, lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -288,26 +35,21 @@ f"> */
--tauq;
--taup;
--work;
/* Function Body */
*info = 0;
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
i__1 = 1, i__2 = ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1, i__2);
lwkopt = (*m + *n) * nb;
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*lwork < max(i__1,*n) && ! lquery) {
} else {
i__1 = max(1, *m);
if (*lwork < max(i__1, *n) && !lquery) {
*info = -10;
}
}
@ -318,39 +60,21 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
minmn = min(*m,*n);
minmn = min(*m, *n);
if (minmn == 0) {
work[1] = 1.;
return 0;
}
ws = max(*m,*n);
ws = max(*m, *n);
ldwrkx = *m;
ldwrky = *n;
if (nb > 1 && nb < minmn) {
/* Set the crossover point NX. */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
/* Determine when to switch from blocked to unblocked code. */
i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1, i__2);
if (nx < minmn) {
ws = (*m + *n) * nb;
if (*lwork < ws) {
/* Not enough work space for the optimal NB, consider using */
/* a smaller block size. */
nbmin = ilaenv_(&c__2, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nbmin = ilaenv_(&c__2, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
if (*lwork >= (*m + *n) * nbmin) {
nb = *lwork / (*m + *n);
} else {
@ -362,70 +86,44 @@ f"> */
} else {
nx = minmn;
}
i__1 = minmn - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Reduce rows and columns i:i+nb-1 to bidiagonal form and return */
/* the matrices X and Y which are needed to update the unreduced */
/* part of the matrix */
i__3 = *m - i__ + 1;
i__4 = *n - i__ + 1;
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
* nb + 1], &ldwrky);
/* 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 */
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 * nb + 1], &ldwrky);
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
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], &
ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, (
ftnlen)12, (ftnlen)9);
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], &ldwrky, &c_b22,
&a[i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)12, (ftnlen)9);
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
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, &
c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)12, (
ftnlen)12);
/* Copy diagonal and off-diagonal elements of B back into A */
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, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda,
(ftnlen)12, (ftnlen)12);
if (*m >= *n) {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
a[j + j * a_dim1] = d__[j];
a[j + (j + 1) * a_dim1] = e[j];
/* L10: */
}
} else {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
a[j + j * a_dim1] = d__[j];
a[j + 1 + j * a_dim1] = e[j];
/* L20: */
}
}
/* L30: */
}
/* Use unblocked code to reduce the remainder of the matrix */
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
tauq[i__], &taup[i__], &work[1], &iinfo);
work[1] = (doublereal) ws;
dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tauq[i__], &taup[i__],
&work[1], &iinfo);
work[1] = (doublereal)ws;
return 0;
/* End of DGEBRD */
} /* dgebrd_ */
}
#ifdef __cplusplus
}
}
#endif

258
lib/linalg/dgecon.cpp
View File

@ -1,157 +1,13 @@
/* fortran/dgecon.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DGECON */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGECON + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgecon.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgecon.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgecon.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, */
/* INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER NORM */
/* INTEGER INFO, LDA, N */
/* DOUBLE PRECISION ANORM, RCOND */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IWORK( * ) */
/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGECON estimates the reciprocal of the condition number of a general */
/* > real matrix A, in either the 1-norm or the infinity-norm, using */
/* > the LU factorization computed by DGETRF. */
/* > */
/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* > condition number is computed as */
/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] NORM */
/* > \verbatim */
/* > NORM is CHARACTER*1 */
/* > Specifies whether the 1-norm condition number or the */
/* > infinity-norm condition number is required: */
/* > = '1' or 'O': 1-norm; */
/* > = 'I': Infinity-norm. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > The factors L and U from the factorization A = P*L*U */
/* > as computed by DGETRF. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] ANORM */
/* > \verbatim */
/* > ANORM is DOUBLE PRECISION */
/* > If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* > If NORM = 'I', the infinity-norm of the original matrix A. */
/* > \endverbatim */
/* > */
/* > \param[out] RCOND */
/* > \verbatim */
/* > RCOND is DOUBLE PRECISION */
/* > The reciprocal of the condition number of the matrix A, */
/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (4*N) */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension (N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* ===================================================================== */
/* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer *
lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *
iwork, integer *info, ftnlen norm_len)
int dgecon_(char *norm, integer *n, doublereal *a, integer *lda, doublereal *anorm,
doublereal *rcond, doublereal *work, integer *iwork, integer *info, ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Local variables */
doublereal sl;
integer ix;
doublereal su;
@ -159,64 +15,31 @@ f"> */
doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer isave[3];
extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
integer *), dlacn2_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
extern int drscl_(integer *, doublereal *, doublereal *, integer *),
dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *);
extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
doublereal ainvnm;
extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
extern int dlatrs_(char *, char *, char *, char *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen);
logical onenrm;
char normin[1];
doublereal smlnum;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, (char *)"O", (ftnlen)1, (
ftnlen)1);
if (! onenrm && ! lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1);
if (!onenrm && !lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
} else if (*lda < max(1, *n)) {
*info = -4;
} else if (*anorm < 0.) {
*info = -5;
@ -226,9 +49,6 @@ f"> */
xerbla_((char *)"DGECON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
@ -236,11 +56,7 @@ f"> */
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_((char *)"Safe minimum", (ftnlen)12);
/* Estimate the norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
@ -253,61 +69,33 @@ L10:
dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
dlatrs_((char *)"Lower", (char *)"No transpose", (char *)"Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5,
(ftnlen)12, (ftnlen)4, (ftnlen)1);
/* Multiply by inv(U). */
dlatrs_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
dlatrs_((char *)"Lower", (char *)"No transpose", (char *)"Unit", normin, n, &a[a_offset], lda, &work[1], &sl,
&work[(*n << 1) + 1], info, (ftnlen)5, (ftnlen)12, (ftnlen)4, (ftnlen)1);
dlatrs_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", normin, n, &a[a_offset], lda, &work[1],
&su, &work[*n * 3 + 1], info, (ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(U**T). */
dlatrs_((char *)"Upper", (char *)"Transpose", (char *)"Non-unit", normin, n, &a[a_offset],
lda, &work[1], &su, &work[*n * 3 + 1], info, (ftnlen)5, (
ftnlen)9, (ftnlen)8, (ftnlen)1);
/* Multiply by inv(L**T). */
dlatrs_((char *)"Lower", (char *)"Transpose", (char *)"Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5,
(ftnlen)9, (ftnlen)4, (ftnlen)1);
dlatrs_((char *)"Upper", (char *)"Transpose", (char *)"Non-unit", normin, n, &a[a_offset], lda, &work[1], &su,
&work[*n * 3 + 1], info, (ftnlen)5, (ftnlen)9, (ftnlen)8, (ftnlen)1);
dlatrs_((char *)"Lower", (char *)"Transpose", (char *)"Unit", normin, n, &a[a_offset], lda, &work[1], &sl,
&work[(*n << 1) + 1], info, (ftnlen)5, (ftnlen)9, (ftnlen)4, (ftnlen)1);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 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;
}
drscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L20:
return 0;
/* End of DGECON */
} /* dgecon_ */
}
#ifdef __cplusplus
}
}
#endif

218
lib/linalg/dgelq2.cpp
View File

@ -1,204 +1,28 @@
/* fortran/dgelq2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorit
hm. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGELQ2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgelq2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgelq2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgelq2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGELQ2 computes an LQ factorization of a real m-by-n matrix A: */
/* > */
/* > A = ( L 0 ) * Q */
/* > */
/* > where: */
/* > */
/* > Q is a n-by-n orthogonal matrix; */
/* > L is a lower-triangular m-by-m matrix; */
/* > 0 is a m-by-(n-m) zero matrix, if m < n. */
/* > */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the m by n matrix A. */
/* > On exit, the elements on and below the diagonal of the array */
/* > contain the m by min(m,n) lower trapezoidal matrix L (L is */
/* > lower triangular if m <= n); the elements above the diagonal, */
/* > with the array TAU, represent the orthogonal matrix Q as a */
/* > product of elementary reflectors (see Further Details). */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors (see Further */
/* > Details). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (M) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The matrix Q is represented as a product of elementary reflectors */
/* > */
/* > Q = H(k) . . . H(2) H(1), where k = min(m,n). */
/* > */
/* > Each H(i) has the form */
/* > */
/* > H(i) = I - tau * v * v**T */
/* > */
/* > where tau is a real scalar, and v is a real vector with */
/* > v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
/* > and tau in TAU(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info)
int dgelq2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, k;
doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info != 0) {
@ -206,40 +30,24 @@ f"> */
xerbla_((char *)"DGELQ2", &i__1, (ftnlen)6);
return 0;
}
k = min(*m,*n);
k = min(*m, *n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * a_dim1]
, lda, &tau[i__]);
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda, &tau[i__]);
if (i__ < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
i__2 = *m - i__;
i__3 = *n - i__ + 1;
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)
5);
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)5);
a[i__ + i__ * a_dim1] = aii;
}
/* L10: */
}
return 0;
/* End of DGELQ2 */
} /* dgelq2_ */
}
#ifdef __cplusplus
}
}
#endif

305
lib/linalg/dgelqf.cpp
View File

@ -1,237 +1,45 @@
/* fortran/dgelqf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
/* > \brief \b DGELQF */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGELQF + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgelqf.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgelqf.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgelqf.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGELQF computes an LQ factorization of a real M-by-N matrix A: */
/* > */
/* > A = ( L 0 ) * Q */
/* > */
/* > where: */
/* > */
/* > Q is a N-by-N orthogonal matrix; */
/* > L is a lower-triangular M-by-M matrix; */
/* > 0 is a M-by-(N-M) zero matrix, if M < N. */
/* > */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the M-by-N matrix A. */
/* > On exit, the elements on and below the diagonal of the array */
/* > contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
/* > lower triangular if m <= n); the elements above the diagonal, */
/* > with the array TAU, represent the orthogonal matrix Q as a */
/* > product of elementary reflectors (see Further Details). */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors (see Further */
/* > Details). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK >= max(1,M). */
/* > For optimum performance LWORK >= M*NB, where NB is the */
/* > optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The matrix Q is represented as a product of elementary reflectors */
/* > */
/* > Q = H(k) . . . H(2) H(1), where k = min(m,n). */
/* > */
/* > Each H(i) has the form */
/* > */
/* > H(i) = I - tau * v * v**T */
/* > */
/* > where tau is a real scalar, and v is a real vector with */
/* > v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
/* > and tau in TAU(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
int dgelqf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dgelq2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
nb = ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1);
nb = ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = *m * nb;
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
} else if (*lwork < max(1,*m) && ! lquery) {
} else if (*lwork < max(1, *m) && !lquery) {
*info = -7;
}
if (*info != 0) {
@ -241,105 +49,58 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
k = min(*m, *n);
if (k == 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
nx = 0;
iws = *m;
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1, i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *m;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the LQ factorization of the current block */
/* A(i:i+ib-1,i:n) */
ib = min(i__3, nb);
i__3 = *n - i__ + 1;
dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo);
if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *n - i__ + 1;
dlarft_((char *)"Forward", (char *)"Rowwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)7);
/* Apply H to A(i+ib:m,i:n) from the right */
dlarft_((char *)"Forward", (char *)"Rowwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__],
&work[1], &ldwork, (ftnlen)7, (ftnlen)7);
i__3 = *m - i__ - ib + 1;
i__4 = *n - i__ + 1;
dlarfb_((char *)"Right", (char *)"No transpose", (char *)"Forward", (char *)"Rowwise", &i__3,
&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
1], &ldwork, (ftnlen)5, (ftnlen)12, (ftnlen)7, (
ftnlen)7);
dlarfb_((char *)"Right", (char *)"No transpose", (char *)"Forward", (char *)"Rowwise", &i__3, &i__4, &ib,
&a[i__ + i__ * a_dim1], lda, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1],
lda, &work[ib + 1], &ldwork, (ftnlen)5, (ftnlen)12, (ftnlen)7, (ftnlen)7);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo);
}
work[1] = (doublereal) iws;
work[1] = (doublereal)iws;
return 0;
/* End of DGELQF */
} /* dgelqf_ */
}
#ifdef __cplusplus
}
}
#endif

795
lib/linalg/dgelsd.cpp
View File

@ -1,322 +1,60 @@
/* fortran/dgelsd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__6 = 6;
static integer c_n1 = -1;
static integer c__9 = 9;
static integer c__0 = 0;
static integer c__1 = 1;
static doublereal c_b82 = 0.;
/* > \brief <b> DGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices</b
> */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGELSD + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgelsd.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgelsd.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgelsd.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, */
/* WORK, LWORK, IWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK */
/* DOUBLE PRECISION RCOND */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IWORK( * ) */
/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGELSD computes the minimum-norm solution to a real linear least */
/* > squares problem: */
/* > minimize 2-norm(| b - A*x |) */
/* > using the singular value decomposition (SVD) of A. A is an M-by-N */
/* > matrix which may be rank-deficient. */
/* > */
/* > Several right hand side vectors b and solution vectors x can be */
/* > handled in a single call; they are stored as the columns of the */
/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/* > matrix X. */
/* > */
/* > The problem is solved in three steps: */
/* > (1) Reduce the coefficient matrix A to bidiagonal form with */
/* > Householder transformations, reducing the original problem */
/* > into a (char *)"bidiagonal least squares problem" (BLS) */
/* > (2) Solve the BLS using a divide and conquer approach. */
/* > (3) Apply back all the Householder transformations to solve */
/* > the original least squares problem. */
/* > */
/* > The effective rank of A is determined by treating as zero those */
/* > singular values which are less than RCOND times the largest singular */
/* > value. */
/* > */
/* > The divide and conquer algorithm makes very mild assumptions about */
/* > floating point arithmetic. It will work on machines with a guard */
/* > digit in add/subtract, or on those binary machines without guard */
/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* > without guard digits, but we know of none. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] NRHS */
/* > \verbatim */
/* > NRHS is INTEGER */
/* > The number of right hand sides, i.e., the number of columns */
/* > of the matrices B and X. NRHS >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the M-by-N matrix A. */
/* > On exit, A has been destroyed. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in,out] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* > On entry, the M-by-NRHS right hand side matrix B. */
/* > On exit, B is overwritten by the N-by-NRHS solution */
/* > matrix X. If m >= n and RANK = n, the residual */
/* > sum-of-squares for the solution in the i-th column is given */
/* > by the sum of squares of elements n+1:m in that column. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > The leading dimension of the array B. LDB >= max(1,max(M,N)). */
/* > \endverbatim */
/* > */
/* > \param[out] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The singular values of A in decreasing order. */
/* > The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
/* > \endverbatim */
/* > */
/* > \param[in] RCOND */
/* > \verbatim */
/* > RCOND is DOUBLE PRECISION */
/* > RCOND is used to determine the effective rank of A. */
/* > Singular values S(i) <= RCOND*S(1) are treated as zero. */
/* > If RCOND < 0, machine precision is used instead. */
/* > \endverbatim */
/* > */
/* > \param[out] RANK */
/* > \verbatim */
/* > RANK is INTEGER */
/* > The effective rank of A, i.e., the number of singular values */
/* > which are greater than RCOND*S(1). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK must be at least 1. */
/* > The exact minimum amount of workspace needed depends on M, */
/* > N and NRHS. As long as LWORK is at least */
/* > 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */
/* > if M is greater than or equal to N or */
/* > 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */
/* > if M is less than N, the code will execute correctly. */
/* > SMLSIZ is returned by ILAENV and is equal to the maximum */
/* > size of the subproblems at the bottom of the computation */
/* > tree (usually about 25), and */
/* > NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
/* > For good performance, LWORK should generally be larger. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */
/* > LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN), */
/* > where MINMN = MIN( M,N ). */
/* > On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: the algorithm for computing the SVD failed to converge; */
/* > if INFO = i, i off-diagonal elements of an intermediate */
/* > bidiagonal form did not converge to zero. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEsolve */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* > California at Berkeley, USA \n */
/* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */
/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
integer *iwork, integer *info)
int dgelsd_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublereal *work,
integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer ie, il, mm;
doublereal eps, anrm, bnrm;
integer itau, nlvl, iascl, ibscl;
doublereal sfmin;
integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, ftnlen);
extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlalsd_(char *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, ftnlen), dlascl_(char *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, ftnlen), dgeqrf_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, ftnlen), xerbla_(char *,
integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dlabad_(doublereal *, doublereal *),
dgebrd_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *, ftnlen),
dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *, ftnlen);
extern int dgelqf_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *),
dlalsd_(char *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, integer *, ftnlen),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dgeqrf_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
doublereal bignum;
extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen, ftnlen, ftnlen);
extern int dormbr_(char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
integer wlalsd;
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
extern int dormlq_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
extern int dormqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen, ftnlen);
integer liwork, minwrk, maxwrk;
doublereal smlnum;
logical lquery;
integer smlsiz;
/* -- LAPACK driver routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -326,13 +64,10 @@ f"> */
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, (char *)"DGELSD", (char *)" ", m, n, nrhs, &c_n1, (ftnlen)6, (
ftnlen)1);
minmn = min(*m, *n);
maxmn = max(*m, *n);
mnthr = ilaenv_(&c__6, (char *)"DGELSD", (char *)" ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen)1);
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
@ -340,158 +75,105 @@ f"> */
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
} else if (*ldb < max(1, maxmn)) {
*info = -7;
}
smlsiz = ilaenv_(&c__9, (char *)"DGELSD", (char *)" ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
/* Compute workspace. */
/* (Note: Comments in the code beginning (char *)"Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
smlsiz = ilaenv_(&c__9, (char *)"DGELSD", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1);
minwrk = 1;
liwork = 1;
minmn = max(1,minmn);
/* Computing MAX */
i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) /
log(2.)) + 1;
nlvl = max(i__1,0);
minmn = max(1, minmn);
i__1 = (integer)(log((doublereal)minmn / (doublereal)(smlsiz + 1)) / log(2.)) + 1;
nlvl = max(i__1, 0);
if (*info == 0) {
maxwrk = 0;
liwork = minmn * 3 * nlvl + minmn * 11;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, (char *)"DORMQR", (char *)"LT",
m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2);
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1,
(ftnlen)6, (ftnlen)1);
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, (char *)"DORMQR", (char *)"LT", m, nrhs, n, &c_n1,
(ftnlen)6, (ftnlen)2);
maxwrk = max(i__1, i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
/* Computing MAX */
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);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR",
(char *)"QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
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);
maxwrk = max(i__1,i__2);
/* Computing 2nd power */
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);
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", (char *)"QLT", &mm, nrhs, n,
&c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1, i__2);
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);
maxwrk = max(i__1, i__2);
i__1 = smlsiz + 1;
wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *
nrhs + i__1 * i__1;
/* Computing MAX */
wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *nrhs + i__1 * i__1;
i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2),
i__2 = *n * 3 + wlalsd;
minwrk = max(i__1,i__2);
maxwrk = 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;
minwrk = max(i__1, i__2);
}
if (*n > *m) {
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *
nrhs + i__1 * i__1;
wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *nrhs + i__1 * i__1;
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more columns */
/* than rows. */
maxwrk = *m + *m * ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1,
&c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, m, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, m, &c_n1, (ftnlen)6, (
ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", m, nrhs, m, &c_n1, (
ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
maxwrk = *m + *m * ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) +
(*m << 1) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, m, &c_n1, &c_n1,
(ftnlen)6, (ftnlen)1);
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) +
*nrhs * ilaenv_(&c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, m, &c_n1,
(ftnlen)6, (ftnlen)3);
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) +
(*m - 1) * ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", m, nrhs, m, &c_n1,
(ftnlen)6, (ftnlen)3);
maxwrk = max(i__1, i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
maxwrk = max(i__1, i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
maxwrk = max(i__1, i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, (char *)"DORMLQ",
(char *)"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, (char *)"DORMLQ", (char *)"LT", n, nrhs, m, &c_n1,
(ftnlen)6, (ftnlen)2);
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
maxwrk = max(i__1,i__2);
/* XXX: Ensure the Path 2a case below is triggered. The workspace */
/* calculation should use queries for all routines eventually. */
/* Computing MAX */
/* Computing MAX */
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;
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);
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;
i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3, i__4);
maxwrk = max(i__1, i__2);
} else {
/* Path 2 - remaining underdetermined cases. */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR"
, (char *)"QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, (char *)"DORMBR",
(char *)"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1,
(ftnlen)6, (ftnlen)1);
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, n,
&c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", n, nrhs, m,
&c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
maxwrk = max(i__1,i__2);
maxwrk = max(i__1, i__2);
}
/* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2),
i__2 = *m * 3 + wlalsd;
minwrk = 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;
minwrk = max(i__1, i__2);
}
minwrk = min(minwrk,maxwrk);
work[1] = (doublereal) maxwrk;
minwrk = min(minwrk, maxwrk);
work[1] = (doublereal)maxwrk;
iwork[1] = liwork;
if (*lwork < minwrk && ! lquery) {
if (*lwork < minwrk && !lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DGELSD", &i__1, (ftnlen)6);
@ -499,318 +181,161 @@ f"> */
} else if (lquery) {
goto L10;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters. */
eps = dlamch_((char *)"P", (ftnlen)1);
sfmin = dlamch_((char *)"S", (ftnlen)1);
smlnum = sfmin / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
anrm = dlange_((char *)"M", m, n, &a[a_offset], lda, &work[1], (ftnlen)1);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info, (ftnlen)1);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info, (ftnlen)1);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb, (ftnlen)
1);
i__1 = max(*m, *n);
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb, (ftnlen)1);
dlaset_((char *)"F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1, (ftnlen)1);
*rank = 0;
goto L10;
}
/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
bnrm = dlange_((char *)"M", m, nrhs, &b[b_offset], ldb, &work[1], (ftnlen)1);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
ibscl = 2;
}
/* If M < N make sure certain entries of B are zero. */
if (*m < *n) {
i__1 = *n - *m;
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, (
ftnlen)1);
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, (ftnlen)1);
}
/* Overdetermined case. */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
itau = 1;
nwork = itau + *n;
/* Compute A=Q*R. */
/* (Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
/* Multiply B by transpose(Q). */
/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, info);
i__1 = *lwork - nwork + 1;
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, (
ftnlen)1);
/* Zero out below R. */
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, (ftnlen)1);
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlaset_((char *)"L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2],
lda, (ftnlen)1);
dlaset_((char *)"L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], lda, (ftnlen)1);
}
}
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
/* Bidiagonalize R in A. */
/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R. */
/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__1, info);
i__1 = *lwork - nwork + 1;
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, (
ftnlen)1, (ftnlen)1);
/* Solve the bidiagonal least squares problem. */
dlalsd_((char *)"U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)1);
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, (ftnlen)1, (ftnlen)1);
dlalsd_((char *)"U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, rcond, rank,
&work[nwork], &iwork[1], info, (ftnlen)1);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of R. */
i__1 = *lwork - nwork + 1;
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, (
ftnlen)1, (ftnlen)1);
} else /* if(complicated condition) */ {
/* Computing 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);
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) {
/* Path 2a - underdetermined, with many more columns than rows */
/* and sufficient workspace for an efficient algorithm. */
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, (ftnlen)1, (ftnlen)1);
} else {
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);
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1, wlalsd)) {
ldwork = *m;
/* Computing MAX */
/* Computing MAX */
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;
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 * *lda + wlalsd;
if (*lwork >= max(i__1,i__2)) {
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;
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 * *lda + wlalsd;
if (*lwork >= max(i__1, i__2)) {
ldwork = *lda;
}
itau = 1;
nwork = *m + 1;
/* Compute A=L*Q. */
/* (Workspace: need 2*M, prefer M+M*NB) */
i__1 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, info);
il = nwork;
/* Copy L to WORK(IL), zeroing out above its diagonal. */
dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen)
1);
dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen)1);
i__1 = *m - 1;
i__2 = *m - 1;
dlaset_((char *)"U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &
ldwork, (ftnlen)1);
dlaset_((char *)"U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &ldwork, (ftnlen)1);
ie = il + ldwork * *m;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize L in WORK(IL). */
/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
&work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of L. */
/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__1, info);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[nwork], &i__1, info, (
ftnlen)1, (ftnlen)1, (ftnlen)1);
/* Solve the bidiagonal least squares problem. */
dlalsd_((char *)"U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)
1);
dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[itauq], &b[b_offset], ldb,
&work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlalsd_((char *)"U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], ldb, rcond, rank,
&work[nwork], &iwork[1], info, (ftnlen)1);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of L. */
i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"L", (char *)"N", m, nrhs, m, &work[il], &ldwork, &work[
itaup], &b[b_offset], ldb, &work[nwork], &i__1, info, (
ftnlen)1, (ftnlen)1, (ftnlen)1);
/* Zero out below first M rows of B. */
dormbr_((char *)"P", (char *)"L", (char *)"N", m, nrhs, m, &work[il], &ldwork, &work[itaup], &b[b_offset], ldb,
&work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *n - *m;
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1],
ldb, (ftnlen)1);
dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, (ftnlen)1);
nwork = itau + *m;
/* Multiply transpose(Q) by B. */
/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
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, (
ftnlen)1);
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, (ftnlen)1);
} else {
/* Path 2 - remaining underdetermined cases. */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize A. */
/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors. */
/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__1, info);
i__1 = *lwork - nwork + 1;
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,
(ftnlen)1, (ftnlen)1);
/* Solve the bidiagonal least squares problem. */
dlalsd_((char *)"L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)
1);
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, (ftnlen)1, (ftnlen)1);
dlalsd_((char *)"L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], ldb, rcond, rank,
&work[nwork], &iwork[1], info, (ftnlen)1);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of A. */
i__1 = *lwork - nwork + 1;
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,
(ftnlen)1, (ftnlen)1);
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, (ftnlen)1, (ftnlen)1);
}
}
/* Undo scaling. */
if (iascl == 1) {
dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &minmn, info, (ftnlen)1);
} else if (iascl == 2) {
dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &minmn, info, (ftnlen)1);
}
if (ibscl == 1) {
dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
} else if (ibscl == 2) {
dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
}
L10:
work[1] = (doublereal) maxwrk;
work[1] = (doublereal)maxwrk;
iwork[1] = liwork;
return 0;
/* End of DGELSD */
} /* dgelsd_ */
}
#ifdef __cplusplus
}
}
#endif

930
lib/linalg/dgelss.cpp
View File

File diff suppressed because it is too large Load Diff

317
lib/linalg/dgemm.cpp
View File

@ -1,250 +1,18 @@
/* fortran/dgemm.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DGEMM */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION ALPHA,BETA */
/* INTEGER K,LDA,LDB,LDC,M,N */
/* CHARACTER TRANSA,TRANSB */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGEMM performs one of the matrix-matrix operations */
/* > */
/* > C := alpha*op( A )*op( B ) + beta*C, */
/* > */
/* > where op( X ) is one of */
/* > */
/* > op( X ) = X or op( X ) = X**T, */
/* > */
/* > alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
/* > an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] TRANSA */
/* > \verbatim */
/* > TRANSA is CHARACTER*1 */
/* > On entry, TRANSA specifies the form of op( A ) to be used in */
/* > the matrix multiplication as follows: */
/* > */
/* > TRANSA = 'N' or 'n', op( A ) = A. */
/* > */
/* > TRANSA = 'T' or 't', op( A ) = A**T. */
/* > */
/* > TRANSA = 'C' or 'c', op( A ) = A**T. */
/* > \endverbatim */
/* > */
/* > \param[in] TRANSB */
/* > \verbatim */
/* > TRANSB is CHARACTER*1 */
/* > On entry, TRANSB specifies the form of op( B ) to be used in */
/* > the matrix multiplication as follows: */
/* > */
/* > TRANSB = 'N' or 'n', op( B ) = B. */
/* > */
/* > TRANSB = 'T' or 't', op( B ) = B**T. */
/* > */
/* > TRANSB = 'C' or 'c', op( B ) = B**T. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > On entry, M specifies the number of rows of the matrix */
/* > op( A ) and of the matrix C. M must be at least zero. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > On entry, N specifies the number of columns of the matrix */
/* > op( B ) and the number of columns of the matrix C. N must be */
/* > at least zero. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > On entry, K specifies the number of columns of the matrix */
/* > op( A ) and the number of rows of the matrix op( B ). K must */
/* > be at least zero. */
/* > \endverbatim */
/* > */
/* > \param[in] ALPHA */
/* > \verbatim */
/* > ALPHA is DOUBLE PRECISION. */
/* > On entry, ALPHA specifies the scalar alpha. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is */
/* > k when TRANSA = 'N' or 'n', and is m otherwise. */
/* > Before entry with TRANSA = 'N' or 'n', the leading m by k */
/* > part of the array A must contain the matrix A, otherwise */
/* > the leading k by m part of the array A must contain the */
/* > matrix A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > On entry, LDA specifies the first dimension of A as declared */
/* > in the calling (sub) program. When TRANSA = 'N' or 'n' then */
/* > LDA must be at least max( 1, m ), otherwise LDA must be at */
/* > least max( 1, k ). */
/* > \endverbatim */
/* > */
/* > \param[in] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is */
/* > n when TRANSB = 'N' or 'n', and is k otherwise. */
/* > Before entry with TRANSB = 'N' or 'n', the leading k by n */
/* > part of the array B must contain the matrix B, otherwise */
/* > the leading n by k part of the array B must contain the */
/* > matrix B. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > On entry, LDB specifies the first dimension of B as declared */
/* > in the calling (sub) program. When TRANSB = 'N' or 'n' then */
/* > LDB must be at least max( 1, k ), otherwise LDB must be at */
/* > least max( 1, n ). */
/* > \endverbatim */
/* > */
/* > \param[in] BETA */
/* > \verbatim */
/* > BETA is DOUBLE PRECISION. */
/* > On entry, BETA specifies the scalar beta. When BETA is */
/* > supplied as zero then C need not be set on input. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension ( LDC, N ) */
/* > Before entry, the leading m by n part of the array C must */
/* > contain the matrix C, except when beta is zero, in which */
/* > case C need not be set on entry. */
/* > On exit, the array C is overwritten by the m by n matrix */
/* > ( alpha*op( A )*op( B ) + beta*C ). */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > On entry, LDC specifies the first dimension of C as declared */
/* > in the calling (sub) program. LDC must be at least */
/* > max( 1, m ). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level3 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Level 3 Blas routine. */
/* > */
/* > -- Written on 8-February-1989. */
/* > Jack Dongarra, Argonne National Laboratory. */
/* > Iain Duff, AERE Harwell. */
/* > Jeremy Du Croz, Numerical Algorithms Group Ltd. */
/* > Sven Hammarling, Numerical Algorithms Group Ltd. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
integer *ldc, ftnlen transa_len, ftnlen transb_len)
int dgemm_(char *transa, char *transb, integer *m, integer *n, integer *k, doublereal *alpha,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *beta,
doublereal *c__, integer *ldc, ftnlen transa_len, ftnlen transb_len)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3;
/* Local variables */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3;
integer i__, j, l, info;
logical nota, notb;
doublereal temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nrowa, nrowb;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- Reference BLAS level3 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* Set NOTA and NOTB as true if A and B respectively are not */
/* transposed and set NROWA and NROWB as the number of rows of A */
/* and B respectively. */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -254,8 +22,6 @@ extern "C" {
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
/* Function Body */
nota = lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1);
notb = lsame_(transb, (char *)"N", (ftnlen)1, (ftnlen)1);
if (nota) {
@ -268,15 +34,12 @@ extern "C" {
} else {
nrowb = *n;
}
/* Test the input parameters. */
info = 0;
if (! nota && ! lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1) && ! lsame_(
transa, (char *)"T", (ftnlen)1, (ftnlen)1)) {
if (!nota && !lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1) &&
!lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (! notb && ! lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1) && !
lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) {
} else if (!notb && !lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1) &&
!lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) {
info = 2;
} else if (*m < 0) {
info = 3;
@ -284,26 +47,20 @@ extern "C" {
info = 4;
} else if (*k < 0) {
info = 5;
} else if (*lda < max(1,nrowa)) {
} else if (*lda < max(1, nrowa)) {
info = 8;
} else if (*ldb < max(1,nrowb)) {
} else if (*ldb < max(1, nrowb)) {
info = 10;
} else if (*ldc < max(1,*m)) {
} else if (*ldc < max(1, *m)) {
info = 13;
}
if (info != 0) {
xerbla_((char *)"DGEMM ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
return 0;
}
/* And if alpha.eq.zero. */
if (*alpha == 0.) {
if (*beta == 0.) {
i__1 = *n;
@ -311,9 +68,7 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
@ -321,34 +76,24 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L30: */
}
/* L40: */
}
}
return 0;
}
/* Start the operations. */
if (notb) {
if (nota) {
/* Form C := alpha*A*B + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.;
/* L50: */
}
} else if (*beta != 1.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L60: */
}
}
i__2 = *k;
@ -357,16 +102,10 @@ extern "C" {
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1];
/* L70: */
}
/* L80: */
}
/* L90: */
}
} else {
/* Form C := alpha*A**T*B + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
@ -375,37 +114,28 @@ extern "C" {
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
/* L100: */
}
if (*beta == 0.) {
c__[i__ + j * c_dim1] = *alpha * temp;
} else {
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
i__ + j * c_dim1];
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[i__ + j * c_dim1];
}
/* L110: */
}
/* L120: */
}
}
} else {
if (nota) {
/* Form C := alpha*A*B**T + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.;
/* L130: */
}
} else if (*beta != 1.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L140: */
}
}
i__2 = *k;
@ -414,16 +144,10 @@ extern "C" {
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1];
/* L150: */
}
/* L160: */
}
/* L170: */
}
} else {
/* Form C := alpha*A**T*B**T + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
@ -432,27 +156,18 @@ extern "C" {
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
/* L180: */
}
if (*beta == 0.) {
c__[i__ + j * c_dim1] = *alpha * temp;
} else {
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
i__ + j * c_dim1];
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[i__ + j * c_dim1];
}
/* L190: */
}
/* L200: */
}
}
}
return 0;
/* End of DGEMM */
} /* dgemm_ */
}
#ifdef __cplusplus
}
}
#endif

254
lib/linalg/dgemv.cpp
View File

@ -1,231 +1,31 @@
/* fortran/dgemv.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DGEMV */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION ALPHA,BETA */
/* INTEGER INCX,INCY,LDA,M,N */
/* CHARACTER TRANS */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A(LDA,*),X(*),Y(*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGEMV performs one of the matrix-vector operations */
/* > */
/* > y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, */
/* > */
/* > where alpha and beta are scalars, x and y are vectors and A is an */
/* > m by n matrix. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > On entry, TRANS specifies the operation to be performed as */
/* > follows: */
/* > */
/* > TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
/* > */
/* > TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. */
/* > */
/* > TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > On entry, M specifies the number of rows of the matrix A. */
/* > M must be at least zero. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > On entry, N specifies the number of columns of the matrix A. */
/* > N must be at least zero. */
/* > \endverbatim */
/* > */
/* > \param[in] ALPHA */
/* > \verbatim */
/* > ALPHA is DOUBLE PRECISION. */
/* > On entry, ALPHA specifies the scalar alpha. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension ( LDA, N ) */
/* > Before entry, the leading m by n part of the array A must */
/* > contain the matrix of coefficients. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > On entry, LDA specifies the first dimension of A as declared */
/* > in the calling (sub) program. LDA must be at least */
/* > max( 1, m ). */
/* > \endverbatim */
/* > */
/* > \param[in] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION array, dimension at least */
/* > ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
/* > and at least */
/* > ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
/* > Before entry, the incremented array X must contain the */
/* > vector x. */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > On entry, INCX specifies the increment for the elements of */
/* > X. INCX must not be zero. */
/* > \endverbatim */
/* > */
/* > \param[in] BETA */
/* > \verbatim */
/* > BETA is DOUBLE PRECISION. */
/* > On entry, BETA specifies the scalar beta. When BETA is */
/* > supplied as zero then Y need not be set on input. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Y */
/* > \verbatim */
/* > Y is DOUBLE PRECISION array, dimension at least */
/* > ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
/* > and at least */
/* > ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
/* > Before entry with BETA non-zero, the incremented array Y */
/* > must contain the vector y. On exit, Y is overwritten by the */
/* > updated vector y. */
/* > \endverbatim */
/* > */
/* > \param[in] INCY */
/* > \verbatim */
/* > INCY is INTEGER */
/* > On entry, INCY specifies the increment for the elements of */
/* > Y. INCY must not be zero. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level2 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Level 2 Blas routine. */
/* > The vector and matrix arguments are not referenced when N = 0, or M = 0 */
/* > */
/* > -- Written on 22-October-1986. */
/* > Jack Dongarra, Argonne National Lab. */
/* > Jeremy Du Croz, Nag Central Office. */
/* > Sven Hammarling, Nag Central Office. */
/* > Richard Hanson, Sandia National Labs. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
doublereal *beta, doublereal *y, integer *incy, ftnlen trans_len)
int dgemv_(char *trans, integer *m, integer *n, doublereal *alpha, doublereal *a, integer *lda,
doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy,
ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, j, ix, iy, jx, jy, kx, ky, info;
doublereal temp;
integer lenx, leny;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- Reference BLAS level2 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--y;
/* Function Body */
info = 0;
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)
) {
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)) {
info = 1;
} else if (*m < 0) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
info = 6;
} else if (*incx == 0) {
info = 8;
@ -236,16 +36,9 @@ extern "C" {
xerbla_((char *)"DGEMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
return 0;
}
/* Set LENX and LENY, the lengths of the vectors x and y, and set */
/* up the start points in X and Y. */
if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) {
lenx = *n;
leny = *m;
@ -263,25 +56,17 @@ extern "C" {
} else {
ky = 1 - (leny - 1) * *incy;
}
/* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (*beta != 1.) {
if (*incy == 1) {
if (*beta == 0.) {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L10: */
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
@ -291,14 +76,12 @@ extern "C" {
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
@ -307,9 +90,6 @@ extern "C" {
return 0;
}
if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (*incy == 1) {
i__1 = *n;
@ -318,10 +98,8 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += temp * a[i__ + j * a_dim1];
/* L50: */
}
jx += *incx;
/* L60: */
}
} else {
i__1 = *n;
@ -332,16 +110,11 @@ extern "C" {
for (i__ = 1; i__ <= i__2; ++i__) {
y[iy] += temp * a[i__ + j * a_dim1];
iy += *incy;
/* L70: */
}
jx += *incx;
/* L80: */
}
}
} else {
/* Form y := alpha*A**T*x + y. */
jy = ky;
if (*incx == 1) {
i__1 = *n;
@ -350,11 +123,9 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp += a[i__ + j * a_dim1] * x[i__];
/* L90: */
}
y[jy] += *alpha * temp;
jy += *incy;
/* L100: */
}
} else {
i__1 = *n;
@ -365,21 +136,14 @@ extern "C" {
for (i__ = 1; i__ <= i__2; ++i__) {
temp += a[i__ + j * a_dim1] * x[ix];
ix += *incx;
/* L110: */
}
y[jy] += *alpha * temp;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of DGEMV */
} /* dgemv_ */
}
#ifdef __cplusplus
}
}
#endif

222
lib/linalg/dgeqr2.cpp
View File

@ -1,209 +1,29 @@
/* fortran/dgeqr2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorit
hm. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGEQR2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgeqr2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgeqr2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgeqr2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGEQR2 computes a QR factorization of a real m-by-n matrix A: */
/* > */
/* > A = Q * ( R ), */
/* > ( 0 ) */
/* > */
/* > where: */
/* > */
/* > Q is a m-by-m orthogonal matrix; */
/* > R is an upper-triangular n-by-n matrix; */
/* > 0 is a (m-n)-by-n zero matrix, if m > n. */
/* > */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the m by n matrix A. */
/* > On exit, the elements on and above the diagonal of the array */
/* > contain the min(m,n) by n upper trapezoidal matrix R (R is */
/* > upper triangular if m >= n); the elements below the diagonal, */
/* > with the array TAU, represent the orthogonal matrix Q as a */
/* > product of elementary reflectors (see Further Details). */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors (see Further */
/* > Details). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The matrix Q is represented as a product of elementary reflectors */
/* > */
/* > Q = H(1) H(2) . . . H(k), where k = min(m,n). */
/* > */
/* > Each H(i) has the form */
/* > */
/* > H(i) = I - tau * v * v**T */
/* > */
/* > where tau is a real scalar, and v is a real vector with */
/* > v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
/* > and tau in TAU(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info)
int dgeqr2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, k;
doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info != 0) {
@ -211,40 +31,24 @@ f"> */
xerbla_((char *)"DGEQR2", &i__1, (ftnlen)6);
return 0;
}
k = min(*m,*n);
k = min(*m, *n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1]
, &c__1, &tau[i__]);
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1, &tau[i__]);
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
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], (
ftnlen)4);
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], (ftnlen)4);
a[i__ + i__ * a_dim1] = aii;
}
/* L10: */
}
return 0;
/* End of DGEQR2 */
} /* dgeqr2_ */
}
#ifdef __cplusplus
}
}
#endif

311
lib/linalg/dgeqrf.cpp
View File

@ -1,240 +1,45 @@
/* fortran/dgeqrf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
/* > \brief \b DGEQRF */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGEQRF + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgeqrf.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgeqrf.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgeqrf.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGEQRF computes a QR factorization of a real M-by-N matrix A: */
/* > */
/* > A = Q * ( R ), */
/* > ( 0 ) */
/* > */
/* > where: */
/* > */
/* > Q is a M-by-M orthogonal matrix; */
/* > R is an upper-triangular N-by-N matrix; */
/* > 0 is a (M-N)-by-N zero matrix, if M > N. */
/* > */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the M-by-N matrix A. */
/* > On exit, the elements on and above the diagonal of the array */
/* > contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
/* > upper triangular if m >= n); the elements below the diagonal, */
/* > with the array TAU, represent the orthogonal matrix Q as a */
/* > product of min(m,n) elementary reflectors (see Further */
/* > Details). */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (min(M,N)) */
/* > The scalar factors of the elementary reflectors (see Further */
/* > Details). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. */
/* > LWORK >= 1, if MIN(M,N) = 0, and LWORK >= N, otherwise. */
/* > For optimum performance LWORK >= N*NB, where NB is */
/* > the optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The matrix Q is represented as a product of elementary reflectors */
/* > */
/* > Q = H(1) H(2) . . . H(k), where k = min(m,n). */
/* > */
/* > Each H(i) has the form */
/* > */
/* > H(i) = I - tau * v * v**T */
/* > */
/* > where tau is a real scalar, and v is a real vector with */
/* > v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
/* > and tau in TAU(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
int dgeqrf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dgeqr2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
k = min(*m,*n);
k = min(*m, *n);
*info = 0;
nb = ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1);
nb = ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
} else if (! lquery) {
if (*lwork <= 0 || *m > 0 && *lwork < max(1,*n)) {
} else if (!lquery) {
if (*lwork <= 0 || *m > 0 && *lwork < max(1, *n)) {
*info = -7;
}
}
@ -248,107 +53,61 @@ f"> */
} else {
lwkopt = *n * nb;
}
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
return 0;
}
/* Quick return if possible */
if (k == 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1, i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the QR factorization of the current block */
/* A(i:m,i:i+ib-1) */
ib = min(i__3, nb);
i__3 = *m - i__ + 1;
dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *m - i__ + 1;
dlarft_((char *)"Forward", (char *)"Columnwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)10);
/* Apply H**T to A(i:m,i+ib:n) from the left */
dlarft_((char *)"Forward", (char *)"Columnwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__],
&work[1], &ldwork, (ftnlen)7, (ftnlen)10);
i__3 = *m - i__ + 1;
i__4 = *n - i__ - ib + 1;
dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, &
i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib
+ 1], &ldwork, (ftnlen)4, (ftnlen)9, (ftnlen)7, (
ftnlen)10);
dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, &i__4, &ib,
&a[i__ + i__ * a_dim1], lda, &work[1], &ldwork,
&a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + 1], &ldwork, (ftnlen)4,
(ftnlen)9, (ftnlen)7, (ftnlen)10);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo);
}
work[1] = (doublereal) iws;
work[1] = (doublereal)iws;
return 0;
/* End of DGEQRF */
} /* dgeqrf_ */
}
#ifdef __cplusplus
}
}
#endif

200
lib/linalg/dger.cpp
View File

@ -1,191 +1,19 @@
/* fortran/dger.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DGER */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION ALPHA */
/* INTEGER INCX,INCY,LDA,M,N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A(LDA,*),X(*),Y(*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGER performs the rank 1 operation */
/* > */
/* > A := alpha*x*y**T + A, */
/* > */
/* > where alpha is a scalar, x is an m element vector, y is an n element */
/* > vector and A is an m by n matrix. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > On entry, M specifies the number of rows of the matrix A. */
/* > M must be at least zero. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > On entry, N specifies the number of columns of the matrix A. */
/* > N must be at least zero. */
/* > \endverbatim */
/* > */
/* > \param[in] ALPHA */
/* > \verbatim */
/* > ALPHA is DOUBLE PRECISION. */
/* > On entry, ALPHA specifies the scalar alpha. */
/* > \endverbatim */
/* > */
/* > \param[in] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION array, dimension at least */
/* > ( 1 + ( m - 1 )*abs( INCX ) ). */
/* > Before entry, the incremented array X must contain the m */
/* > element vector x. */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > On entry, INCX specifies the increment for the elements of */
/* > X. INCX must not be zero. */
/* > \endverbatim */
/* > */
/* > \param[in] Y */
/* > \verbatim */
/* > Y is DOUBLE PRECISION array, dimension at least */
/* > ( 1 + ( n - 1 )*abs( INCY ) ). */
/* > Before entry, the incremented array Y must contain the n */
/* > element vector y. */
/* > \endverbatim */
/* > */
/* > \param[in] INCY */
/* > \verbatim */
/* > INCY is INTEGER */
/* > On entry, INCY specifies the increment for the elements of */
/* > Y. INCY must not be zero. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension ( LDA, N ) */
/* > Before entry, the leading m by n part of the array A must */
/* > contain the matrix of coefficients. On exit, A is */
/* > overwritten by the updated matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > On entry, LDA specifies the first dimension of A as declared */
/* > in the calling (sub) program. LDA must be at least */
/* > max( 1, m ). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup double_blas_level2 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Level 2 Blas routine. */
/* > */
/* > -- Written on 22-October-1986. */
/* > Jack Dongarra, Argonne National Lab. */
/* > Jeremy Du Croz, Nag Central Office. */
/* > Sven Hammarling, Nag Central Office. */
/* > Richard Hanson, Sandia National Labs. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha,
doublereal *x, integer *incx, doublereal *y, integer *incy,
doublereal *a, integer *lda)
int dger_(integer *m, integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *y,
integer *incy, doublereal *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, j, ix, jy, kx, info;
doublereal temp;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- Reference BLAS level2 routine -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen);
--x;
--y;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
info = 0;
if (*m < 0) {
info = 1;
@ -195,23 +23,16 @@ extern "C" {
info = 5;
} else if (*incy == 0) {
info = 7;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
info = 9;
}
if (info != 0) {
xerbla_((char *)"DGER ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || *alpha == 0.) {
return 0;
}
/* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */
if (*incy > 0) {
jy = 1;
} else {
@ -225,11 +46,9 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[i__] * temp;
/* L10: */
}
}
jy += *incy;
/* L20: */
}
} else {
if (*incx > 0) {
@ -246,20 +65,13 @@ extern "C" {
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[ix] * temp;
ix += *incx;
/* L30: */
}
}
jy += *incy;
/* L40: */
}
}
return 0;
/* End of DGER */
} /* dger_ */
}
#ifdef __cplusplus
}
}
#endif

197
lib/linalg/dgesv.cpp
View File

@ -1,176 +1,15 @@
/* fortran/dgesv.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief <b> DGESV computes the solution to system of linear equations A * X = B for GE matrices</b> */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGESV + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgesv.f
"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgesv.f
"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgesv.f
"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, LDB, N, NRHS */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IPIV( * ) */
/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGESV computes the solution to a real system of linear equations */
/* > A * X = B, */
/* > where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* > */
/* > The LU decomposition with partial pivoting and row interchanges is */
/* > used to factor A as */
/* > A = P * L * U, */
/* > where P is a permutation matrix, L is unit lower triangular, and U is */
/* > upper triangular. The factored form of A is then used to solve the */
/* > system of equations A * X = B. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of linear equations, i.e., the order of the */
/* > matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] NRHS */
/* > \verbatim */
/* > NRHS is INTEGER */
/* > The number of right hand sides, i.e., the number of columns */
/* > of the matrix B. NRHS >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the N-by-N coefficient matrix A. */
/* > On exit, the factors L and U from the factorization */
/* > A = P*L*U; the unit diagonal elements of L are not stored. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[out] IPIV */
/* > \verbatim */
/* > IPIV is INTEGER array, dimension (N) */
/* > The pivot indices that define the permutation matrix P; */
/* > row i of the matrix was interchanged with row IPIV(i). */
/* > \endverbatim */
/* > */
/* > \param[in,out] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* > On entry, the N-by-NRHS matrix of right hand side matrix B. */
/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > The leading dimension of the array B. LDB >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
/* > has been completed, but the factor U is exactly */
/* > singular, so the solution could not be computed. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEsolve */
/* ===================================================================== */
/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer
*lda, integer *ipiv, doublereal *b, integer *ldb, integer *info)
int dgesv_(integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b,
integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen), dgetrs_(char *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *, ftnlen);
/* -- LAPACK driver routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int dgetrf_(integer *, integer *, doublereal *, integer *, integer *, integer *),
xerbla_(char *, integer *, ftnlen),
dgetrs_(char *, integer *, integer *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -178,16 +17,14 @@ extern "C" {
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
} else if (*lda < max(1, *n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
} else if (*ldb < max(1, *n)) {
*info = -7;
}
if (*info != 0) {
@ -195,23 +32,13 @@ extern "C" {
xerbla_((char *)"DGESV ", &i__1, (ftnlen)6);
return 0;
}
/* Compute the LU factorization of A. */
dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
dgetrs_((char *)"No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
b_offset], ldb, info, (ftnlen)12);
dgetrs_((char *)"No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb, info,
(ftnlen)12);
}
return 0;
/* End of DGESV */
} /* dgesv_ */
}
#ifdef __cplusplus
}
}
#endif

3844
lib/linalg/dgesvd.cpp
View File

File diff suppressed because it is too large Load Diff

216
lib/linalg/dgetf2.cpp
View File

@ -1,194 +1,32 @@
/* fortran/dgetf2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = -1.;
/* > \brief \b DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row
interchanges (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGETF2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgetf2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgetf2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgetf2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IPIV( * ) */
/* DOUBLE PRECISION A( LDA, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGETF2 computes an LU factorization of a general m-by-n matrix A */
/* > using partial pivoting with row interchanges. */
/* > */
/* > The factorization has the form */
/* > A = P * L * U */
/* > where P is a permutation matrix, L is lower triangular with unit */
/* > diagonal elements (lower trapezoidal if m > n), and U is upper */
/* > triangular (upper trapezoidal if m < n). */
/* > */
/* > This is the right-looking Level 2 BLAS version of the algorithm. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the m by n matrix to be factored. */
/* > On exit, the factors L and U from the factorization */
/* > A = P*L*U; the unit diagonal elements of L are not stored. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] IPIV */
/* > \verbatim */
/* > IPIV is INTEGER array, dimension (min(M,N)) */
/* > The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* > matrix was interchanged with row IPIV(i). */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -k, the k-th argument had an illegal value */
/* > > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* > has been completed, but the factor U is exactly */
/* > singular, and division by zero will occur if it is used */
/* > to solve a system of equations. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* ===================================================================== */
/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
int dgetf2_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j, jp;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dscal_(integer *, doublereal *, doublereal *, integer
*);
extern int dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *),
dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal sfmin;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info != 0) {
@ -196,35 +34,19 @@ f"> */
xerbla_((char *)"DGETF2", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = dlamch_((char *)"S", (ftnlen)1);
i__1 = min(*m,*n);
i__1 = min(*m, *n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
if (a[jp + j * a_dim1] != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) {
i__2 = *m - j;
@ -234,33 +56,21 @@ f"> */
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
if (j < min(*m, *n)) {
i__2 = *m - j;
i__3 = *n - 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);
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);
}
/* L10: */
}
return 0;
/* End of DGETF2 */
} /* dgetf2_ */
}
#ifdef __cplusplus
}
}
#endif

261
lib/linalg/dgetrf.cpp
View File

@ -1,197 +1,38 @@
/* fortran/dgetrf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b16 = 1.;
static doublereal c_b19 = -1.;
/* > \brief \b DGETRF */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGETRF + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgetrf.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgetrf.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgetrf.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IPIV( * ) */
/* DOUBLE PRECISION A( LDA, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGETRF computes an LU factorization of a general M-by-N matrix A */
/* > using partial pivoting with row interchanges. */
/* > */
/* > The factorization has the form */
/* > A = P * L * U */
/* > where P is a permutation matrix, L is lower triangular with unit */
/* > diagonal elements (lower trapezoidal if m > n), and U is upper */
/* > triangular (upper trapezoidal if m < n). */
/* > */
/* > This is the right-looking Level 3 BLAS version of the algorithm. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the M-by-N matrix to be factored. */
/* > On exit, the factors L and U from the factorization */
/* > A = P*L*U; the unit diagonal elements of L are not stored. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] IPIV */
/* > \verbatim */
/* > IPIV is INTEGER array, dimension (min(M,N)) */
/* > The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* > matrix was interchanged with row IPIV(i). */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
/* > has been completed, but the factor U is exactly */
/* > singular, and division by zero will occur if it is used */
/* > to solve a system of equations. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* ===================================================================== */
/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
int dgetrf_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */
integer i__, j, jb, nb;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer iinfo;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_(
char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *), dgetrf2_(integer *,
integer *, doublereal *, integer *, integer *, integer *);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dlaswp_(integer *, doublereal *, integer *, integer *, integer *, integer *,
integer *),
dgetrf2_(integer *, integer *, doublereal *, integer *, integer *, integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info != 0) {
@ -199,95 +40,51 @@ f"> */
xerbla_((char *)"DGETRF", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, (char *)"DGETRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1);
if (nb <= 1 || nb >= min(*m,*n)) {
/* Use unblocked code. */
nb = ilaenv_(&c__1, (char *)"DGETRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
if (nb <= 1 || nb >= min(*m, *n)) {
dgetrf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
} else {
/* Use blocked code. */
i__1 = min(*m,*n);
i__1 = min(*m, *n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = min(*m,*n) - j + 1;
jb = min(i__3,nb);
/* Factor diagonal and subdiagonal blocks and test for exact */
/* singularity. */
i__3 = min(*m, *n) - j + 1;
jb = min(i__3, nb);
i__3 = *m - j + 1;
dgetrf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
/* Adjust INFO and the pivot indices. */
if (*info == 0 && iinfo > 0) {
*info = iinfo + j - 1;
}
/* Computing MIN */
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__) {
ipiv[i__] = j - 1 + ipiv[i__];
/* L10: */
}
/* Apply interchanges to columns 1:J-1. */
i__3 = j - 1;
i__4 = j + jb - 1;
dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
if (j + jb <= *n) {
/* Apply interchanges to columns J+JB:N. */
i__3 = *n - j - jb + 1;
i__4 = j + jb - 1;
dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
ipiv[1], &c__1);
/* Compute block row of U. */
dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &ipiv[1], &c__1);
i__3 = *n - j - jb + 1;
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) *
a_dim1], lda, (ftnlen)4, (ftnlen)5, (ftnlen)12, (
ftnlen)4);
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) * a_dim1], lda, (ftnlen)4,
(ftnlen)5, (ftnlen)12, (ftnlen)4);
if (j + jb <= *m) {
/* Update trailing submatrix. */
i__3 = *m - j - jb + 1;
i__4 = *n - j - jb + 1;
dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb,
&c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j +
jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) *
a_dim1], lda, (ftnlen)12, (ftnlen)12);
dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb, &c_b19,
&a[j + jb + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, &c_b16,
&a[j + jb + (j + jb) * a_dim1], lda, (ftnlen)12, (ftnlen)12);
}
}
/* L20: */
}
}
return 0;
/* End of DGETRF */
} /* dgetrf_ */
}
#ifdef __cplusplus
}
}
#endif

271
lib/linalg/dgetrf2.cpp
View File

@ -1,201 +1,39 @@
/* static/dgetrf2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b13 = 1.;
static doublereal c_b16 = -1.;
/* > \brief \b DGETRF2 */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IPIV( * ) */
/* DOUBLE PRECISION A( LDA, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGETRF2 computes an LU factorization of a general M-by-N matrix A */
/* > using partial pivoting with row interchanges. */
/* > */
/* > The factorization has the form */
/* > A = P * L * U */
/* > where P is a permutation matrix, L is lower triangular with unit */
/* > diagonal elements (lower trapezoidal if m > n), and U is upper */
/* > triangular (upper trapezoidal if m < n). */
/* > */
/* > This is the recursive version of the algorithm. It divides */
/* > the matrix into four submatrices: */
/* > */
/* > [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 */
/* > A = [ -----|----- ] with n1 = min(m,n)/2 */
/* > [ A21 | A22 ] n2 = n-n1 */
/* > */
/* > [ A11 ] */
/* > The subroutine calls itself to factor [ --- ], */
/* > [ A12 ] */
/* > [ A12 ] */
/* > do the swaps on [ --- ], solve A12, update A22, */
/* > [ A22 ] */
/* > */
/* > then calls itself to factor A22 and do the swaps on A21. */
/* > */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the M-by-N matrix to be factored. */
/* > On exit, the factors L and U from the factorization */
/* > A = P*L*U; the unit diagonal elements of L are not stored. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] IPIV */
/* > \verbatim */
/* > IPIV is INTEGER array, dimension (min(M,N)) */
/* > The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* > matrix was interchanged with row IPIV(i). */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
/* > has been completed, but the factor U is exactly */
/* > singular, and division by zero will occur if it is used */
/* > to solve a system of equations. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* ===================================================================== */
/* Subroutine */ int dgetrf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
int dgetrf2_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, n1, n2;
doublereal temp;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen, ftnlen);
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen);
integer iinfo;
doublereal sfmin;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen);
extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlaswp_(
integer *, doublereal *, integer *, integer *, integer *, integer
*, integer *);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen),
dlaswp_(integer *, doublereal *, integer *, integer *, integer *, integer *, integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info != 0) {
@ -203,47 +41,24 @@ static doublereal c_b16 = -1.;
xerbla_((char *)"DGETRF2", &i__1, (ftnlen)7);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
if (*m == 1) {
/* Use unblocked code for one row case */
/* Just need to handle IPIV and INFO */
ipiv[1] = 1;
if (a[a_dim1 + 1] == 0.) {
*info = 1;
}
} else if (*n == 1) {
/* Use unblocked code for one column case */
/* Compute machine safe minimum */
sfmin = dlamch_((char *)"S", (ftnlen)1);
/* Find pivot and test for singularity */
i__ = idamax_(m, &a[a_dim1 + 1], &c__1);
ipiv[1] = i__;
if (a[i__ + a_dim1] != 0.) {
/* Apply the interchange */
if (i__ != 1) {
temp = a[a_dim1 + 1];
a[a_dim1 + 1] = a[i__ + a_dim1];
a[i__ + a_dim1] = temp;
}
/* Compute elements 2:M of the column */
if ((d__1 = a[a_dim1 + 1], abs(d__1)) >= sfmin) {
i__1 = *m - 1;
d__1 = 1. / a[a_dim1 + 1];
@ -252,80 +67,40 @@ static doublereal c_b16 = -1.;
i__1 = *m - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + 1 + a_dim1] /= a[a_dim1 + 1];
/* L10: */
}
}
} else {
*info = 1;
}
} else {
/* Use recursive code */
n1 = min(*m,*n) / 2;
n1 = min(*m, *n) / 2;
n2 = *n - n1;
/* [ A11 ] */
/* Factor [ --- ] */
/* [ A21 ] */
dgetrf2_(m, &n1, &a[a_offset], lda, &ipiv[1], &iinfo);
if (*info == 0 && iinfo > 0) {
*info = iinfo;
}
/* [ A12 ] */
/* Apply interchanges to [ --- ] */
/* [ A22 ] */
dlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], &
c__1);
/* Solve A12 */
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, (
ftnlen)1);
/* Update A22 */
dlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], &c__1);
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, (ftnlen)1);
i__1 = *m - n1;
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_dim1], lda, (ftnlen)1, (ftnlen)1);
/* Factor A22 */
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_dim1], lda,
(ftnlen)1, (ftnlen)1);
i__1 = *m - n1;
dgetrf2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &ipiv[n1 +
1], &iinfo);
/* Adjust INFO and the pivot indices */
dgetrf2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &ipiv[n1 + 1], &iinfo);
if (*info == 0 && iinfo > 0) {
*info = iinfo + n1;
}
i__1 = min(*m,*n);
i__1 = min(*m, *n);
for (i__ = n1 + 1; i__ <= i__1; ++i__) {
ipiv[i__] += n1;
/* L20: */
}
/* Apply interchanges to A21 */
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);
}
return 0;
/* End of DGETRF2 */
} /* dgetrf2_ */
}
#ifdef __cplusplus
}
}
#endif

286
lib/linalg/dgetri.cpp
View File

@ -1,216 +1,49 @@
/* fortran/dgetri.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
static doublereal c_b20 = -1.;
static doublereal c_b22 = 1.;
/* > \brief \b DGETRI */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGETRI + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgetri.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgetri.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgetri.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, LDA, LWORK, N */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IPIV( * ) */
/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGETRI computes the inverse of a matrix using the LU factorization */
/* > computed by DGETRF. */
/* > */
/* > This method inverts U and then computes inv(A) by solving the system */
/* > inv(A)*L = inv(U) for inv(A). */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the factors L and U from the factorization */
/* > A = P*L*U as computed by DGETRF. */
/* > On exit, if INFO = 0, the inverse of the original matrix A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] IPIV */
/* > \verbatim */
/* > IPIV is INTEGER array, dimension (N) */
/* > The pivot indices from DGETRF; for 1<=i<=N, row i of the */
/* > matrix was interchanged with row IPIV(i). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK >= max(1,N). */
/* > For optimal performance LWORK >= N*NB, where NB is */
/* > the optimal blocksize returned by ILAENV. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */
/* > singular and its inverse could not be computed. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* ===================================================================== */
/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer
*ipiv, doublereal *work, integer *lwork, integer *info)
int dgetri_(integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, jb, nb, jj, jp, nn, iws;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen),
dgemv_(char *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, ftnlen);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen),
dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen);
integer nbmin;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_(
char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *),
dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork;
extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal
*, integer *, integer *, ftnlen, ftnlen);
extern int dtrtri_(char *, char *, integer *, doublereal *, integer *, integer *, ftnlen,
ftnlen);
integer lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
/* Function Body */
*info = 0;
nb = ilaenv_(&c__1, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = ilaenv_(&c__1, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = *n * nb;
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
} else if (*lda < max(1, *n)) {
*info = -3;
} else if (*lwork < max(1,*n) && ! lquery) {
} else if (*lwork < max(1, *n) && !lquery) {
*info = -6;
}
if (*info != 0) {
@ -220,124 +53,73 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */
/* and the inverse is not computed. */
dtrtri_((char *)"Upper", (char *)"Non-unit", n, &a[a_offset], lda, info, (ftnlen)5, (
ftnlen)8);
dtrtri_((char *)"Upper", (char *)"Non-unit", n, &a[a_offset], lda, info, (ftnlen)5, (ftnlen)8);
if (*info > 0) {
return 0;
}
nbmin = 2;
ldwork = *n;
if (nb > 1 && nb < *n) {
/* Computing MAX */
i__1 = ldwork * nb;
iws = max(i__1,1);
iws = max(i__1, 1);
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
} else {
iws = *n;
}
/* Solve the equation inv(A)*L = inv(U) for inv(A). */
if (nb < nbmin || nb >= *n) {
/* Use unblocked code. */
for (j = *n; j >= 1; --j) {
/* Copy current column of L to WORK and replace with zeros. */
i__1 = *n;
for (i__ = j + 1; i__ <= i__1; ++i__) {
work[i__] = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* Compute current column of inv(A). */
if (j < *n) {
i__1 = *n - j;
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], &c__1, (ftnlen)12);
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], &c__1, (ftnlen)12);
}
/* L20: */
}
} else {
/* Use blocked code. */
nn = (*n - 1) / nb * nb + 1;
i__1 = -nb;
for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *n - j + 1;
jb = min(i__2,i__3);
/* Copy current block column of L to WORK and replace with */
/* zeros. */
jb = min(i__2, i__3);
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = *n;
for (i__ = jj + 1; i__ <= i__3; ++i__) {
work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1];
a[i__ + jj * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* Compute current block column of inv(A). */
if (j + jb <= *n) {
i__2 = *n - j - jb + 1;
dgemm_((char *)"No transpose", (char *)"No transpose", n, &jb, &i__2, &c_b20,
&a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &
ldwork, &c_b22, &a[j * a_dim1 + 1], lda, (ftnlen)12, (
ftnlen)12);
&a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &ldwork, &c_b22,
&a[j * a_dim1 + 1], lda, (ftnlen)12, (ftnlen)12);
}
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, (
ftnlen)5, (ftnlen)12, (ftnlen)4);
/* L50: */
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, (ftnlen)5, (ftnlen)12, (ftnlen)4);
}
}
/* Apply column interchanges. */
for (j = *n - 1; j >= 1; --j) {
jp = ipiv[j];
if (jp != j) {
dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
}
/* L60: */
}
work[1] = (doublereal) iws;
work[1] = (doublereal)iws;
return 0;
/* End of DGETRI */
} /* dgetri_ */
}
#ifdef __cplusplus
}
}
#endif

249
lib/linalg/dgetrs.cpp
View File

@ -1,191 +1,21 @@
/* fortran/dgetrs.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b12 = 1.;
static integer c_n1 = -1;
/* > \brief \b DGETRS */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DGETRS + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgetrs.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgetrs.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgetrs.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER TRANS */
/* INTEGER INFO, LDA, LDB, N, NRHS */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IPIV( * ) */
/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DGETRS solves a system of linear equations */
/* > A * X = B or A**T * X = B */
/* > with a general N-by-N matrix A using the LU factorization computed */
/* > by DGETRF. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > Specifies the form of the system of equations: */
/* > = 'N': A * X = B (No transpose) */
/* > = 'T': A**T* X = B (Transpose) */
/* > = 'C': A**T* X = B (Conjugate transpose = Transpose) */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] NRHS */
/* > \verbatim */
/* > NRHS is INTEGER */
/* > The number of right hand sides, i.e., the number of columns */
/* > of the matrix B. NRHS >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > The factors L and U from the factorization A = P*L*U */
/* > as computed by DGETRF. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] IPIV */
/* > \verbatim */
/* > IPIV is INTEGER array, dimension (N) */
/* > The pivot indices from DGETRF; for 1<=i<=N, row i of the */
/* > matrix was interchanged with row IPIV(i). */
/* > \endverbatim */
/* > */
/* > \param[in,out] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* > On entry, the right hand side matrix B. */
/* > On exit, the solution matrix X. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > The leading dimension of the array B. LDB >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEcomputational */
/* ===================================================================== */
/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs,
doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
ldb, integer *info, ftnlen trans_len)
int dgetrs_(char *trans, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv,
doublereal *b, integer *ldb, integer *info, ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_(
char *, integer *, ftnlen), dlaswp_(integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *);
extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
xerbla_(char *, integer *, ftnlen),
dlaswp_(integer *, doublereal *, integer *, integer *, integer *, integer *, integer *);
logical notran;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -193,20 +23,18 @@ f"> */
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(
trans, (char *)"C", (ftnlen)1, (ftnlen)1)) {
if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) &&
!lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
} else if (*ldb < max(1, *n)) {
*info = -8;
}
if (*info != 0) {
@ -214,59 +42,24 @@ f"> */
xerbla_((char *)"DGETRS", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (notran) {
/* Solve A * X = B. */
/* Apply row interchanges to the right hand sides. */
dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
/* Solve L*X = B, overwriting B with X. */
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, (
ftnlen)12, (ftnlen)4);
/* Solve U*X = B, overwriting B with X. */
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, (
ftnlen)12, (ftnlen)8);
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, (ftnlen)12, (ftnlen)4);
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, (ftnlen)12, (ftnlen)8);
} else {
/* Solve A**T * X = B. */
/* Solve U**T *X = B, overwriting B with X. */
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, (
ftnlen)9, (ftnlen)8);
/* Solve L**T *X = B, overwriting B with X. */
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, (
ftnlen)9, (ftnlen)4);
/* Apply row interchanges to the solution vectors. */
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, (ftnlen)9, (ftnlen)8);
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, (ftnlen)9, (ftnlen)4);
dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
}
return 0;
/* End of DGETRS */
} /* dgetrs_ */
}
#ifdef __cplusplus
}
}
#endif

4
lib/linalg/disnan.cpp
View File

@ -7,8 +7,8 @@ extern "C" {
logical disnan_(const doublereal *din)
{
if (!din) return TRUE_;
if (!din) return TRUE_;
return std::isnan(*din) ? TRUE_ : FALSE_;
return std::isnan(*din) ? TRUE_ : FALSE_;
}
}

118
lib/linalg/dlabad.cpp
View File

@ -1,128 +1,16 @@
/* fortran/dlabad.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLABAD */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLABAD + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlabad.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlabad.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlabad.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLABAD( SMALL, LARGE ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION LARGE, SMALL */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLABAD takes as input the values computed by DLAMCH for underflow and */
/* > overflow, and returns the square root of each of these values if the */
/* > log of LARGE is sufficiently large. This subroutine is intended to */
/* > identify machines with a large exponent range, such as the Crays, and */
/* > redefine the underflow and overflow limits to be the square roots of */
/* > the values computed by DLAMCH. This subroutine is needed because */
/* > DLAMCH does not compensate for poor arithmetic in the upper half of */
/* > the exponent range, as is found on a Cray. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in,out] SMALL */
/* > \verbatim */
/* > SMALL is DOUBLE PRECISION */
/* > On entry, the underflow threshold as computed by DLAMCH. */
/* > On exit, if LOG10(LARGE) is sufficiently large, the square */
/* > root of SMALL, otherwise unchanged. */
/* > \endverbatim */
/* > */
/* > \param[in,out] LARGE */
/* > \verbatim */
/* > LARGE is DOUBLE PRECISION */
/* > On entry, the overflow threshold as computed by DLAMCH. */
/* > On exit, if LOG10(LARGE) is sufficiently large, the square */
/* > root of LARGE, otherwise unchanged. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlabad_(doublereal *small, doublereal *large)
int dlabad_(doublereal *small, doublereal *large)
{
/* Builtin functions */
double d_lmp_lg10(doublereal *), sqrt(doublereal);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* If it looks like we're on a Cray, take the square root of */
/* SMALL and LARGE to avoid overflow and underflow problems. */
if (d_lmp_lg10(large) > 2e3) {
*small = sqrt(*small);
*large = sqrt(*large);
}
return 0;
/* End of DLABAD */
} /* dlabad_ */
}
#ifdef __cplusplus
}
}
#endif

510
lib/linalg/dlabrd.cpp
View File

@ -1,279 +1,21 @@
/* fortran/dlabrd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b4 = -1.;
static doublereal c_b5 = 1.;
static integer c__1 = 1;
static doublereal c_b16 = 0.;
/* > \brief \b DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLABRD + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlabrd.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlabrd.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlabrd.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, */
/* LDY ) */
/* .. Scalar Arguments .. */
/* INTEGER LDA, LDX, LDY, M, N, NB */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), */
/* $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLABRD reduces the first NB rows and columns of a real general */
/* > m by n matrix A to upper or lower bidiagonal form by an orthogonal */
/* > transformation Q**T * A * P, and returns the matrices X and Y which */
/* > are needed to apply the transformation to the unreduced part of A. */
/* > */
/* > If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
/* > bidiagonal form. */
/* > */
/* > This is an auxiliary routine called by DGEBRD */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows in the matrix A. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns in the matrix A. */
/* > \endverbatim */
/* > */
/* > \param[in] NB */
/* > \verbatim */
/* > NB is INTEGER */
/* > The number of leading rows and columns of A to be reduced. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the m by n general matrix to be reduced. */
/* > On exit, the first NB rows and columns of the matrix are */
/* > overwritten; the rest of the array is unchanged. */
/* > If m >= n, elements on and below the diagonal in the first NB */
/* > columns, with the array TAUQ, represent the orthogonal */
/* > matrix Q as a product of elementary reflectors; and */
/* > elements above the diagonal in the first NB rows, with the */
/* > array TAUP, represent the orthogonal matrix P as a product */
/* > of elementary reflectors. */
/* > If m < n, elements below the diagonal in the first NB */
/* > columns, with the array TAUQ, represent the orthogonal */
/* > matrix Q as a product of elementary reflectors, and */
/* > elements on and above the diagonal in the first NB rows, */
/* > with the array TAUP, represent the orthogonal matrix P as */
/* > a product of elementary reflectors. */
/* > See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (NB) */
/* > The diagonal elements of the first NB rows and columns of */
/* > the reduced matrix. D(i) = A(i,i). */
/* > \endverbatim */
/* > */
/* > \param[out] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (NB) */
/* > The off-diagonal elements of the first NB rows and columns of */
/* > the reduced matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] TAUQ */
/* > \verbatim */
/* > TAUQ is DOUBLE PRECISION array, dimension (NB) */
/* > The scalar factors of the elementary reflectors which */
/* > represent the orthogonal matrix Q. See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[out] TAUP */
/* > \verbatim */
/* > TAUP is DOUBLE PRECISION array, dimension (NB) */
/* > The scalar factors of the elementary reflectors which */
/* > represent the orthogonal matrix P. See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[out] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION array, dimension (LDX,NB) */
/* > The m-by-nb matrix X required to update the unreduced part */
/* > of A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDX */
/* > \verbatim */
/* > LDX is INTEGER */
/* > The leading dimension of the array X. LDX >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] Y */
/* > \verbatim */
/* > Y is DOUBLE PRECISION array, dimension (LDY,NB) */
/* > The n-by-nb matrix Y required to update the unreduced part */
/* > of A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDY */
/* > \verbatim */
/* > LDY is INTEGER */
/* > The leading dimension of the array Y. LDY >= max(1,N). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The matrices Q and P are represented as products of elementary */
/* > reflectors: */
/* > */
/* > Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
/* > */
/* > Each H(i) and G(i) has the form: */
/* > */
/* > H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T */
/* > */
/* > where tauq and taup are real scalars, and v and u are real vectors. */
/* > */
/* > If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
/* > A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
/* > A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* > */
/* > If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
/* > A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
/* > A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* > */
/* > The elements of the vectors v and u together form the m-by-nb matrix */
/* > V and the nb-by-n matrix U**T which are needed, with X and Y, to apply */
/* > the transformation to the unreduced part of the matrix, using a block */
/* > update of the form: A := A - V*Y**T - X*U**T. */
/* > */
/* > The contents of A on exit are illustrated by the following examples */
/* > with nb = 2: */
/* > */
/* > m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* > */
/* > ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
/* > ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
/* > ( v1 v2 a a a ) ( v1 1 a a a a ) */
/* > ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* > ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* > ( v1 v2 a a a ) */
/* > */
/* > where a denotes an element of the original matrix which is unchanged, */
/* > vi denotes an element of the vector defining H(i), and ui an element */
/* > of the vector defining G(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq,
doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer
*ldy)
int dlabrd_(integer *m, integer *n, integer *nb, doublereal *a, integer *lda, doublereal *d__,
doublereal *e, doublereal *tauq, doublereal *taup, doublereal *x, integer *ldx,
doublereal *y, integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
/* Local variables */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, i__3;
integer i__;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -287,246 +29,182 @@ f"> */
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
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], &
c__1, (ftnlen)12);
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], &c__1, (ftnlen)12);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
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_dim1], &c__1, (ftnlen)12);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
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_dim1], &c__1, (ftnlen)12);
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ *
a_dim1], &c__1, &tauq[i__]);
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1,
&tauq[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
if (i__ < *n) {
a[i__ + i__ * a_dim1] = 1.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
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, &
y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9);
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, &y[i__ + 1 + i__ * y_dim1], &c__1,
(ftnlen)9);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
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__ *
y_dim1 + 1], &c__1, (ftnlen)9);
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__ * y_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = *n - i__;
i__3 = 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[
i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * y_dim1], &c__1,
(ftnlen)12);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
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__ *
y_dim1 + 1], &c__1, (ftnlen)9);
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__ * y_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = i__ - 1;
i__3 = *n - i__;
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,
&y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9);
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, &y[i__ + 1 + i__ * y_dim1], &c__1,
(ftnlen)9);
i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (
i__ + 1) * a_dim1], lda, (ftnlen)12);
dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b5, &a[i__ + (i__ + 1) * a_dim1], lda, (ftnlen)12);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[
i__ + (i__ + 1) * a_dim1], lda, (ftnlen)9);
/* Generate reflection P(i) to annihilate A(i,i+2:n) */
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * a_dim1 + 1], lda,
&x[i__ + x_dim1], ldx, &c_b5, &a[i__ + (i__ + 1) * a_dim1], lda, (ftnlen)9);
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
i__3,*n) * a_dim1], lda, &taup[i__]);
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda,
&taup[i__]);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - 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],
lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, (
ftnlen)12);
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + 1) * a_dim1], lda,
&a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1,
(ftnlen)12);
i__2 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1],
ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[
i__ * x_dim1 + 1], &c__1, (ftnlen)9);
dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], ldy,
&a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[i__ * x_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = *m - i__;
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[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * x_dim1], &c__1,
(ftnlen)12);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b16, &x[i__ * x_dim1 + 1], &c__1, (ftnlen)12);
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * a_dim1 + 1], lda,
&a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[i__ * x_dim1 + 1], &c__1,
(ftnlen)12);
i__2 = *m - i__;
i__3 = 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[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * x_dim1], &c__1,
(ftnlen)12);
i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
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],
lda, (ftnlen)12);
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], lda, (ftnlen)12);
i__2 = i__ - 1;
i__3 = *n - i__ + 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, (ftnlen)9);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */
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, (ftnlen)9);
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) *
a_dim1], lda, &taup[i__]);
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda,
&taup[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
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, &
x[i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
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, &x[i__ + 1 + i__ * x_dim1], &c__1,
(ftnlen)12);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1],
ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
x_dim1 + 1], &c__1, (ftnlen)9);
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], ldy,
&a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * x_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *m - i__;
i__3 = 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[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * x_dim1], &c__1,
(ftnlen)12);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
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__ *
x_dim1 + 1], &c__1, (ftnlen)12);
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__ * x_dim1 + 1], &c__1,
(ftnlen)12);
i__2 = *m - i__;
i__3 = 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[
i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * x_dim1], &c__1,
(ftnlen)12);
i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
/* Update A(i+1:m,i) */
i__2 = *m - i__;
i__3 = 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__ +
1 + i__ * a_dim1], &c__1, (ftnlen)12);
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__ + 1 + i__ * a_dim1], &c__1, (ftnlen)12);
i__2 = *m - i__;
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[
i__ + 1 + i__ * a_dim1], &c__1, (ftnlen)12);
/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
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[i__ + 1 + i__ * a_dim1], &c__1,
(ftnlen)12);
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) +
i__ * a_dim1], &c__1, &tauq[i__]);
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1,
&tauq[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - 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,
&c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9);
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, &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1,
(ftnlen)9);
i__2 = *m - i__;
i__3 = i__ - 1;
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[
i__ * y_dim1 + 1], &c__1, (ftnlen)9);
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[i__ * y_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = *n - i__;
i__3 = 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[
i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * y_dim1], &c__1,
(ftnlen)12);
i__2 = *m - i__;
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[
i__ * y_dim1 + 1], &c__1, (ftnlen)9);
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[i__ * y_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = *n - i__;
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 + i__ * y_dim1], &c__1, (ftnlen)9);
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 + i__ * y_dim1], &c__1,
(ftnlen)9);
i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of DLABRD */
} /* dlabrd_ */
}
#ifdef __cplusplus
}
}
#endif

264
lib/linalg/dlacn2.cpp
View File

@ -1,244 +1,53 @@
/* fortran/dlacn2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matr
ix-vector products. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLACN2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlacn2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlacn2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlacn2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) */
/* .. Scalar Arguments .. */
/* INTEGER KASE, N */
/* DOUBLE PRECISION EST */
/* .. */
/* .. Array Arguments .. */
/* INTEGER ISGN( * ), ISAVE( 3 ) */
/* DOUBLE PRECISION V( * ), X( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLACN2 estimates the 1-norm of a square, real matrix A. */
/* > Reverse communication is used for evaluating matrix-vector products. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix. N >= 1. */
/* > \endverbatim */
/* > */
/* > \param[out] V */
/* > \verbatim */
/* > V is DOUBLE PRECISION array, dimension (N) */
/* > On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* > (W is not returned). */
/* > \endverbatim */
/* > */
/* > \param[in,out] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION array, dimension (N) */
/* > On an intermediate return, X should be overwritten by */
/* > A * X, if KASE=1, */
/* > A**T * X, if KASE=2, */
/* > and DLACN2 must be re-called with all the other parameters */
/* > unchanged. */
/* > \endverbatim */
/* > */
/* > \param[out] ISGN */
/* > \verbatim */
/* > ISGN is INTEGER array, dimension (N) */
/* > \endverbatim */
/* > */
/* > \param[in,out] EST */
/* > \verbatim */
/* > EST is DOUBLE PRECISION */
/* > On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
/* > unchanged from the previous call to DLACN2. */
/* > On exit, EST is an estimate (a lower bound) for norm(A). */
/* > \endverbatim */
/* > */
/* > \param[in,out] KASE */
/* > \verbatim */
/* > KASE is INTEGER */
/* > On the initial call to DLACN2, KASE should be 0. */
/* > On an intermediate return, KASE will be 1 or 2, indicating */
/* > whether X should be overwritten by A * X or A**T * X. */
/* > On the final return from DLACN2, KASE will again be 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] ISAVE */
/* > \verbatim */
/* > ISAVE is INTEGER array, dimension (3) */
/* > ISAVE is used to save variables between calls to DLACN2 */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Originally named SONEST, dated March 16, 1988. */
/* > */
/* > This is a thread safe version of DLACON, which uses the array ISAVE */
/* > in place of a SAVE statement, as follows: */
/* > */
/* > DLACON DLACN2 */
/* > JUMP ISAVE(1) */
/* > J ISAVE(2) */
/* > ITER ISAVE(3) */
/* > \endverbatim */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Nick Higham, University of Manchester */
/* > \par References: */
/* ================ */
/* > */
/* > N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* > a real or complex matrix, with applications to condition estimation", */
/* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase, integer *isave)
int dlacn2_(integer *n, doublereal *v, doublereal *x, integer *isgn, doublereal *est, integer *kase,
integer *isave)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer i_lmp_dnnt(doublereal *);
/* Local variables */
integer i__;
doublereal xs, temp;
extern doublereal dasum_(integer *, doublereal *, integer *);
integer jlast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal altsgn, estold;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--isave;
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1. / (doublereal) (*n);
/* L10: */
x[i__] = 1. / (doublereal)(*n);
}
*kase = 1;
isave[1] = 1;
return 0;
}
switch (isave[1]) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
case 1:
goto L20;
case 2:
goto L40;
case 3:
goto L70;
case 4:
goto L110;
case 5:
goto L140;
}
/* ................ ENTRY (ISAVE( 1 ) = 1) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = abs(v[1]);
/* ... QUIT */
goto L150;
}
*est = dasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (x[i__] >= 0.) {
@ -247,35 +56,22 @@ L20:
x[i__] = -1.;
}
isgn[i__] = i_lmp_dnnt(&x[i__]);
/* L30: */
}
*kase = 2;
isave[1] = 2;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 2) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
isave[2] = idamax_(n, &x[1], &c__1);
isave[3] = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.;
/* L60: */
}
x[isave[2]] = 1.;
*kase = 1;
isave[1] = 3;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
@ -290,17 +86,12 @@ L70:
if (i_lmp_dnnt(&xs) != isgn[i__]) {
goto L90;
}
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (x[i__] >= 0.) {
@ -309,15 +100,10 @@ L90:
x[i__] = -1.;
}
isgn[i__] = i_lmp_dnnt(&x[i__]);
/* L100: */
}
*kase = 2;
isave[1] = 4;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 4) */
/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L110:
jlast = isave[2];
isave[2] = idamax_(n, &x[1], &c__1);
@ -325,40 +111,26 @@ L110:
++isave[3];
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
1.);
x[i__] = altsgn * ((doublereal)(i__ - 1) / (doublereal)(*n - 1) + 1.);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
isave[1] = 5;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
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) {
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of DLACN2 */
} /* dlacn2_ */
}
#ifdef __cplusplus
}
}
#endif

164
lib/linalg/dlacpy.cpp
View File

@ -1,172 +1,26 @@
/* fortran/dlacpy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLACPY copies all or part of one two-dimensional array to another. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLACPY + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlacpy.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlacpy.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlacpy.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) */
/* .. Scalar Arguments .. */
/* CHARACTER UPLO */
/* INTEGER LDA, LDB, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLACPY copies all or part of a two-dimensional matrix A to another */
/* > matrix B. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] UPLO */
/* > \verbatim */
/* > UPLO is CHARACTER*1 */
/* > Specifies the part of the matrix A to be copied to B. */
/* > = 'U': Upper triangular part */
/* > = 'L': Lower triangular part */
/* > Otherwise: All of the matrix A */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > The m by n matrix A. If UPLO = 'U', only the upper triangle */
/* > or trapezoid is accessed; if UPLO = 'L', only the lower */
/* > triangle or trapezoid is accessed. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension (LDB,N) */
/* > On exit, B = A in the locations specified by UPLO. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > The leading dimension of the array B. LDB >= max(1,M). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal *
a, integer *lda, doublereal *b, integer *ldb, ftnlen uplo_len)
int dlacpy_(char *uplo, integer *m, integer *n, doublereal *a, integer *lda, doublereal *b,
integer *ldb, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
i__2 = min(j, *m);
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L10: */
}
/* L20: */
}
} else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
@ -174,9 +28,7 @@ f"> */
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L30: */
}
/* L40: */
}
} else {
i__1 = *n;
@ -184,17 +36,11 @@ f"> */
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L50: */
}
/* L60: */
}
}
return 0;
/* End of DLACPY */
} /* dlacpy_ */
}
#ifdef __cplusplus
}
}
#endif

221
lib/linalg/dladiv.cpp
View File

@ -1,156 +1,23 @@
/* fortran/dladiv.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLADIV + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dladiv.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dladiv.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dladiv.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLADIV( A, B, C, D, P, Q ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION A, B, C, D, P, Q */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLADIV performs complex division in real arithmetic */
/* > */
/* > a + i*b */
/* > p + i*q = --------- */
/* > c + i*d */
/* > */
/* > The algorithm is due to Michael Baudin and Robert L. Smith */
/* > and can be found in the paper */
/* > (char *)"A Robust Complex Division in Scilab" */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION */
/* > The scalars a, b, c, and d in the above expression. */
/* > \endverbatim */
/* > */
/* > \param[out] P */
/* > \verbatim */
/* > P is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION */
/* > The scalars p and q in the above expression. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *d__, doublereal *p, doublereal *q)
int dladiv_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *p,
doublereal *q)
{
/* System generated locals */
doublereal d__1, d__2;
/* Local variables */
doublereal s, aa, ab, bb, cc, cd, dd, be, un, ov, eps;
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dladiv1_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
extern int dladiv1_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
aa = *a;
bb = *b;
cc = *c__;
dd = *d__;
/* Computing MAX */
d__1 = abs(*a), d__2 = abs(*b);
ab = max(d__1,d__2);
/* Computing MAX */
ab = max(d__1, d__2);
d__1 = abs(*c__), d__2 = abs(*d__);
cd = max(d__1,d__2);
cd = max(d__1, d__2);
s = 1.;
ov = dlamch_((char *)"Overflow threshold", (ftnlen)18);
un = dlamch_((char *)"Safe minimum", (ftnlen)12);
@ -184,77 +51,26 @@ f"> */
}
*p *= s;
*q *= s;
return 0;
/* End of DLADIV */
} /* dladiv_ */
/* > \ingroup doubleOTHERauxiliary */
/* Subroutine */ int dladiv1_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *d__, doublereal *p, doublereal *q)
}
int dladiv1_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *p,
doublereal *q)
{
doublereal r__, t;
extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
r__ = *d__ / *c__;
t = 1. / (*c__ + *d__ * r__);
*p = dladiv2_(a, b, c__, d__, &r__, &t);
*a = -(*a);
*q = dladiv2_(b, a, c__, d__, &r__, &t);
return 0;
/* End of DLADIV1 */
} /* dladiv1_ */
/* > \ingroup doubleOTHERauxiliary */
doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal
*d__, doublereal *r__, doublereal *t)
}
doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *r__,
doublereal *t)
{
/* System generated locals */
doublereal ret_val;
/* Local variables */
doublereal br;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. */
/* .. Executable Statements .. */
if (*r__ != 0.) {
br = *b * *r__;
if (br != 0.) {
@ -265,13 +81,8 @@ doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal
} else {
ret_val = (*a + *d__ * (*b / *c__)) * *t;
}
return ret_val;
/* End of DLADIV2 */
} /* dladiv2_ */
}
#ifdef __cplusplus
}
}
#endif

171
lib/linalg/dlae2.cpp
View File

@ -1,155 +1,12 @@
/* fortran/dlae2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAE2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlae2.f
"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlae2.f
"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlae2.f
"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION A, B, C, RT1, RT2 */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix */
/* > [ A B ] */
/* > [ B C ]. */
/* > On return, RT1 is the eigenvalue of larger absolute value, and RT2 */
/* > is the eigenvalue of smaller absolute value. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION */
/* > The (1,1) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION */
/* > The (1,2) and (2,1) elements of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION */
/* > The (2,2) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] RT1 */
/* > \verbatim */
/* > RT1 is DOUBLE PRECISION */
/* > The eigenvalue of larger absolute value. */
/* > \endverbatim */
/* > */
/* > \param[out] RT2 */
/* > \verbatim */
/* > RT2 is DOUBLE PRECISION */
/* > The eigenvalue of smaller absolute value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > RT1 is accurate to a few ulps barring over/underflow. */
/* > */
/* > RT2 may be inaccurate if there is massive cancellation in the */
/* > determinant A*C-B*B; higher precision or correctly rounded or */
/* > correctly truncated arithmetic would be needed to compute RT2 */
/* > accurately in all cases. */
/* > */
/* > Overflow is possible only if RT1 is within a factor of 5 of overflow. */
/* > Underflow is harmless if the input data is 0 or exceeds */
/* > underflow_threshold / macheps. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *rt1, doublereal *rt2)
int dlae2_(doublereal *a, doublereal *b, doublereal *c__, doublereal *rt1, doublereal *rt2)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal ab, df, tb, sm, rt, adf, acmn, acmx;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Compute the eigenvalues */
sm = *a + *c__;
df = *a - *c__;
adf = abs(df);
@ -163,48 +20,26 @@ extern "C" {
acmn = *a;
}
if (adf > ab) {
/* Computing 2nd power */
d__1 = ab / adf;
rt = adf * sqrt(d__1 * d__1 + 1.);
} else if (adf < ab) {
/* Computing 2nd power */
d__1 = adf / ab;
rt = ab * sqrt(d__1 * d__1 + 1.);
} else {
/* Includes case AB=ADF=0 */
rt = ab * sqrt(2.);
}
if (sm < 0.) {
*rt1 = (sm - rt) * .5;
/* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else if (sm > 0.) {
*rt1 = (sm + rt) * .5;
/* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else {
/* Includes case RT1 = RT2 = 0 */
*rt1 = rt * .5;
*rt2 = rt * -.5;
}
return 0;
/* End of DLAE2 */
} /* dlae2_ */
}
#ifdef __cplusplus
}
}
#endif

386
lib/linalg/dlaed0.cpp
View File

@ -1,275 +1,48 @@
/* fortran/dlaed0.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__9 = 9;
static integer c__0 = 0;
static integer c__2 = 2;
static doublereal c_b23 = 1.;
static doublereal c_b24 = 0.;
static integer c__1 = 1;
/* > \brief \b DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced
symmetric tridiagonal matrix using the divide and conquer method. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED0 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed0.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed0.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed0.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, */
/* WORK, IWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IWORK( * ) */
/* DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), */
/* $ WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED0 computes all eigenvalues and corresponding eigenvectors of a */
/* > symmetric tridiagonal matrix using the divide and conquer method. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > = 0: Compute eigenvalues only. */
/* > = 1: Compute eigenvectors of original dense symmetric matrix */
/* > also. On entry, Q contains the orthogonal matrix used */
/* > to reduce the original matrix to tridiagonal form. */
/* > = 2: Compute eigenvalues and eigenvectors of tridiagonal */
/* > matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] QSIZ */
/* > \verbatim */
/* > QSIZ is INTEGER */
/* > The dimension of the orthogonal matrix used to reduce */
/* > the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, the main diagonal of the tridiagonal matrix. */
/* > On exit, its eigenvalues. */
/* > \endverbatim */
/* > */
/* > \param[in] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (N-1) */
/* > The off-diagonal elements of the tridiagonal matrix. */
/* > On exit, E has been destroyed. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */
/* > On entry, Q must contain an N-by-N orthogonal matrix. */
/* > If ICOMPQ = 0 Q is not referenced. */
/* > If ICOMPQ = 1 On entry, Q is a subset of the columns of the */
/* > orthogonal matrix used to reduce the full */
/* > matrix to tridiagonal form corresponding to */
/* > the subset of the full matrix which is being */
/* > decomposed at this time. */
/* > If ICOMPQ = 2 On entry, Q will be the identity matrix. */
/* > On exit, Q contains the eigenvectors of the */
/* > tridiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ */
/* > \verbatim */
/* > LDQ is INTEGER */
/* > The leading dimension of the array Q. If eigenvectors are */
/* > desired, then LDQ >= max(1,N). In any case, LDQ >= 1. */
/* > \endverbatim */
/* > */
/* > \param[out] QSTORE */
/* > \verbatim */
/* > QSTORE is DOUBLE PRECISION array, dimension (LDQS, N) */
/* > Referenced only when ICOMPQ = 1. Used to store parts of */
/* > the eigenvector matrix when the updating matrix multiplies */
/* > take place. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQS */
/* > \verbatim */
/* > LDQS is INTEGER */
/* > The leading dimension of the array QSTORE. If ICOMPQ = 1, */
/* > then LDQS >= max(1,N). In any case, LDQS >= 1. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, */
/* > If ICOMPQ = 0 or 1, the dimension of WORK must be at least */
/* > 1 + 3*N + 2*N*lg N + 3*N**2 */
/* > ( lg( N ) = smallest integer k */
/* > such that 2^k >= N ) */
/* > If ICOMPQ = 2, the dimension of WORK must be at least */
/* > 4*N + N**2. */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, */
/* > If ICOMPQ = 0 or 1, the dimension of IWORK must be at least */
/* > 6 + 6*N + 5*N*lg N. */
/* > ( lg( N ) = smallest integer k */
/* > such that 2^k >= N ) */
/* > If ICOMPQ = 2, the dimension of IWORK must be at least */
/* > 3 + 5*N. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: The algorithm failed to compute an eigenvalue while */
/* > working on the submatrix lying in rows and columns */
/* > INFO/(N+1) through mod(INFO,N+1). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* ===================================================================== */
/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n,
doublereal *d__, doublereal *e, doublereal *q, integer *ldq,
doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork,
integer *info)
int dlaed0_(integer *icompq, integer *qsiz, integer *n, doublereal *d__, doublereal *e,
doublereal *q, integer *ldq, doublereal *qstore, integer *ldqs, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal);
integer pow_lmp_ii(integer *, integer *);
/* Local variables */
integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2;
doublereal temp;
integer curr;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer iperm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer indxq, iwrem;
extern /* Subroutine */ int dlaed1_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *);
extern int dlaed1_(integer *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *);
integer iqptr;
extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, doublereal *, integer *, integer *);
extern int dlaed7_(integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *);
integer tlvls;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen);
extern int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen);
integer igivcl;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer igivnm, submat, curprb, subpbs, igivpt;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
extern int dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen);
integer curlvl, matsiz, iprmpt, smlsiz;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
q_dim1 = *ldq;
@ -280,19 +53,16 @@ f"> */
qstore -= qstore_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 2) {
*info = -1;
} else if (*icompq == 1 && *qsiz < max(0,*n)) {
} else if (*icompq == 1 && *qsiz < max(0, *n)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldq < max(1,*n)) {
} else if (*ldq < max(1, *n)) {
*info = -7;
} else if (*ldqs < max(1,*n)) {
} else if (*ldqs < max(1, *n)) {
*info = -9;
}
if (*info != 0) {
@ -300,19 +70,10 @@ f"> */
xerbla_((char *)"DLAED0", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, (char *)"DLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
/* Determine the size and placement of the submatrices, and save in */
/* the leading elements of IWORK. */
smlsiz = ilaenv_(&c__9, (char *)"DLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1);
iwork[1] = *n;
subpbs = 1;
tlvls = 0;
@ -321,7 +82,6 @@ L10:
for (j = subpbs; j >= 1; --j) {
iwork[j * 2] = (iwork[j] + 1) / 2;
iwork[(j << 1) - 1] = iwork[j] / 2;
/* L20: */
}
++tlvls;
subpbs <<= 1;
@ -330,12 +90,7 @@ L10:
i__1 = subpbs;
for (j = 2; j <= i__1; ++j) {
iwork[j] += iwork[j - 1];
/* L30: */
}
/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */
/* using rank-1 modifications (cuts). */
spm1 = subpbs - 1;
i__1 = spm1;
for (i__ = 1; i__ <= i__1; ++i__) {
@ -343,17 +98,11 @@ L10:
smm1 = submat - 1;
d__[smm1] -= (d__1 = e[smm1], abs(d__1));
d__[submat] -= (d__1 = e[smm1], abs(d__1));
/* L40: */
}
indxq = (*n << 2) + 3;
if (*icompq != 2) {
/* Set up workspaces for eigenvalues only/accumulate new vectors */
/* routine */
temp = log((doublereal) (*n)) / log(2.);
lgn = (integer) temp;
temp = log((doublereal)(*n)) / log(2.);
lgn = (integer)temp;
if (pow_lmp_ii(&c__2, &lgn) < *n) {
++lgn;
}
@ -365,27 +114,17 @@ L10:
iqptr = iperm + *n * lgn;
igivpt = iqptr + *n + 2;
igivcl = igivpt + *n * lgn;
igivnm = 1;
iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */
i__1 = *n;
iwrem = iq + i__1 * i__1 + 1;
/* Initialize pointers */
i__1 = subpbs;
for (i__ = 0; i__ <= i__1; ++i__) {
iwork[iprmpt + i__] = 1;
iwork[igivpt + i__] = 1;
/* L50: */
}
iwork[iqptr] = 1;
}
/* Solve each submatrix eigenproblem at the bottom of the divide and */
/* conquer tree. */
curr = 0;
i__1 = spm1;
for (i__ = 0; i__ <= i__1; ++i__) {
@ -397,24 +136,22 @@ L10:
matsiz = iwork[i__ + 1] - iwork[i__];
}
if (*icompq == 2) {
dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &q[submat +
submat * q_dim1], ldq, &work[1], info, (ftnlen)1);
dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &q[submat + submat * q_dim1], ldq,
&work[1], info, (ftnlen)1);
if (*info != 0) {
goto L130;
}
} else {
dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 +
iwork[iqptr + curr]], &matsiz, &work[1], info, (ftnlen)1);
dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + iwork[iqptr + curr]],
&matsiz, &work[1], info, (ftnlen)1);
if (*info != 0) {
goto L130;
}
if (*icompq == 1) {
dgemm_((char *)"N", (char *)"N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat *
q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]],
&matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1],
ldqs, (ftnlen)1, (ftnlen)1);
dgemm_((char *)"N", (char *)"N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * q_dim1 + 1], ldq,
&work[iq - 1 + iwork[iqptr + curr]], &matsiz, &c_b24,
&qstore[submat * qstore_dim1 + 1], ldqs, (ftnlen)1, (ftnlen)1);
}
/* Computing 2nd power */
i__2 = matsiz;
iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
++curr;
@ -424,16 +161,8 @@ L10:
for (j = submat; j <= i__2; ++j) {
iwork[indxq + j] = k;
++k;
/* L60: */
}
/* L70: */
}
/* Successively merge eigensystems of adjacent submatrices */
/* into eigensystem for the corresponding larger matrix. */
/* while ( SUBPBS > 1 ) */
curlvl = 1;
L80:
if (subpbs > 1) {
@ -451,51 +180,32 @@ L80:
msd2 = matsiz / 2;
++curprb;
}
/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
/* into an eigensystem of size MATSIZ. */
/* DLAED1 is used only for the full eigensystem of a tridiagonal */
/* matrix. */
/* DLAED7 handles the cases in which eigenvalues only or eigenvalues */
/* and eigenvectors of a full symmetric matrix (which was reduced to */
/* tridiagonal form) are desired. */
if (*icompq == 2) {
dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1],
ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], &
msd2, &work[1], &iwork[subpbs + 1], info);
dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], ldq,
&iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &work[1],
&iwork[subpbs + 1], info);
} else {
dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[
submat], &qstore[submat * qstore_dim1 + 1], ldqs, &
iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &
work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm]
, &iwork[igivpt], &iwork[igivcl], &work[igivnm], &
work[iwrem], &iwork[subpbs + 1], info);
dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[submat],
&qstore[submat * qstore_dim1 + 1], ldqs, &iwork[indxq + submat],
&e[submat + msd2 - 1], &msd2, &work[iq], &iwork[iqptr], &iwork[iprmpt],
&iwork[iperm], &iwork[igivpt], &iwork[igivcl], &work[igivnm], &work[iwrem],
&iwork[subpbs + 1], info);
}
if (*info != 0) {
goto L130;
}
iwork[i__ / 2 + 1] = iwork[i__ + 2];
/* L90: */
}
subpbs /= 2;
++curlvl;
goto L80;
}
/* end while */
/* Re-merge the eigenvalues/vectors which were deflated at the final */
/* merge step. */
if (*icompq == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__];
work[i__] = d__[j];
dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1
+ 1], &c__1);
/* L100: */
dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1], &c__1);
}
dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
} else if (*icompq == 2) {
@ -504,7 +214,6 @@ L80:
j = iwork[indxq + i__];
work[i__] = d__[j];
dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1);
/* L110: */
}
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);
@ -513,22 +222,15 @@ L80:
for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__];
work[i__] = d__[j];
/* L120: */
}
dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
}
goto L140;
L130:
*info = submat * (*n + 1) + submat + matsiz - 1;
L140:
return 0;
/* End of DLAED0 */
} /* dlaed0_ */
}
#ifdef __cplusplus
}
}
#endif

292
lib/linalg/dlaed1.cpp
View File

@ -1,237 +1,26 @@
/* fortran/dlaed1.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
/* > \brief \b DLAED1 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification
by a rank-one symmetric matrix. Used when the original matrix is tridiagonal. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED1 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed1.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed1.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed1.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, */
/* INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER CUTPNT, INFO, LDQ, N */
/* DOUBLE PRECISION RHO */
/* .. */
/* .. Array Arguments .. */
/* INTEGER INDXQ( * ), IWORK( * ) */
/* DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED1 computes the updated eigensystem of a diagonal */
/* > matrix after modification by a rank-one symmetric matrix. This */
/* > routine is used only for the eigenproblem which requires all */
/* > eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles */
/* > the case in which eigenvalues only or eigenvalues and eigenvectors */
/* > of a full symmetric matrix (which was reduced to tridiagonal form) */
/* > are desired. */
/* > */
/* > T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) */
/* > */
/* > where Z = Q**T*u, u is a vector of length N with ones in the */
/* > CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
/* > */
/* > The eigenvectors of the original matrix are stored in Q, and the */
/* > eigenvalues are in D. The algorithm consists of three stages: */
/* > */
/* > The first stage consists of deflating the size of the problem */
/* > when there are multiple eigenvalues or if there is a zero in */
/* > the Z vector. For each such occurrence the dimension of the */
/* > secular equation problem is reduced by one. This stage is */
/* > performed by the routine DLAED2. */
/* > */
/* > The second stage consists of calculating the updated */
/* > eigenvalues. This is done by finding the roots of the secular */
/* > equation via the routine DLAED4 (as called by DLAED3). */
/* > This routine also calculates the eigenvectors of the current */
/* > problem. */
/* > */
/* > The final stage consists of computing the updated eigenvectors */
/* > directly using the updated eigenvalues. The eigenvectors for */
/* > the current problem are multiplied with the eigenvectors from */
/* > the overall problem. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, the eigenvalues of the rank-1-perturbed matrix. */
/* > On exit, the eigenvalues of the repaired matrix. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */
/* > On entry, the eigenvectors of the rank-1-perturbed matrix. */
/* > On exit, the eigenvectors of the repaired tridiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ */
/* > \verbatim */
/* > LDQ is INTEGER */
/* > The leading dimension of the array Q. LDQ >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in,out] INDXQ */
/* > \verbatim */
/* > INDXQ is INTEGER array, dimension (N) */
/* > On entry, the permutation which separately sorts the two */
/* > subproblems in D into ascending order. */
/* > On exit, the permutation which will reintegrate the */
/* > subproblems back into sorted order, */
/* > i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. */
/* > \endverbatim */
/* > */
/* > \param[in] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > The subdiagonal entry used to create the rank-1 modification. */
/* > \endverbatim */
/* > */
/* > \param[in] CUTPNT */
/* > \verbatim */
/* > CUTPNT is INTEGER */
/* > The location of the last eigenvalue in the leading sub-matrix. */
/* > min(1,N) <= CUTPNT <= N/2. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (4*N + N**2) */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension (4*N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: if INFO = 1, an eigenvalue did not converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA \n */
/* > Modified by Francoise Tisseur, University of Tennessee */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q,
integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt,
doublereal *work, integer *iwork, integer *info)
int dlaed1_(integer *n, doublereal *d__, doublereal *q, integer *ldq, integer *indxq,
doublereal *rho, integer *cutpnt, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
/* Local variables */
integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer indxp;
extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *, integer *), dlaed3_(integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *);
extern int dlaed2_(integer *, integer *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *, integer *),
dlaed3_(integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, integer *);
integer idlmda;
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen);
extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *),
xerbla_(char *, integer *, ftnlen);
integer coltyp;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
@ -239,18 +28,14 @@ f"> */
--indxq;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ldq < max(1,*n)) {
} else if (*ldq < max(1, *n)) {
*info = -4;
} else /* if(complicated condition) */ {
/* Computing MIN */
} else {
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;
}
}
@ -259,60 +44,35 @@ f"> */
xerbla_((char *)"DLAED1", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* The following values are integer pointers which indicate */
/* the portion of the workspace */
/* used by a particular array in DLAED2 and DLAED3. */
iz = 1;
idlmda = iz + *n;
iw = idlmda + *n;
iq2 = iw + *n;
indx = 1;
indxc = indx + *n;
coltyp = indxc + *n;
indxp = coltyp + *n;
/* Form the z-vector which consists of the last row of Q_1 and the */
/* first row of Q_2. */
dcopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1);
zpp1 = *cutpnt + 1;
i__1 = *n - *cutpnt;
dcopy_(&i__1, &q[zpp1 + zpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1);
/* Deflate eigenvalues. */
dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[
iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[
indxc], &iwork[indxp], &iwork[coltyp], info);
dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[iz], &work[idlmda],
&work[iw], &work[iq2], &iwork[indx], &iwork[indxc], &iwork[indxp], &iwork[coltyp],
info);
if (*info != 0) {
goto L20;
}
/* Solve Secular Equation. */
if (k != 0) {
is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp +
1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2;
dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda],
&work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[
is], info);
is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt +
(iwork[coltyp + 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2;
dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], &work[iq2],
&iwork[indxc], &iwork[coltyp], &work[iw], &work[is], info);
if (*info != 0) {
goto L20;
}
/* Prepare the INDXQ sorting permutation. */
n1 = k;
n2 = *n - k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
@ -320,17 +80,11 @@ f"> */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indxq[i__] = i__;
/* L10: */
}
}
L20:
return 0;
/* End of DLAED1 */
} /* dlaed1_ */
}
#ifdef __cplusplus
}
}
#endif

429
lib/linalg/dlaed2.cpp
View File

@ -1,301 +1,34 @@
/* fortran/dlaed2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b3 = -1.;
static integer c__1 = 1;
/* > \brief \b DLAED2 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original
matrix is tridiagonal. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, */
/* Q2, INDX, INDXC, INDXP, COLTYP, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDQ, N, N1 */
/* DOUBLE PRECISION RHO */
/* .. */
/* .. Array Arguments .. */
/* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), */
/* $ INDXQ( * ) */
/* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), */
/* $ W( * ), Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED2 merges the two sets of eigenvalues together into a single */
/* > sorted set. Then it tries to deflate the size of the problem. */
/* > There are two ways in which deflation can occur: when two or more */
/* > eigenvalues are close together or if there is a tiny entry in the */
/* > Z vector. For each such occurrence the order of the related secular */
/* > equation problem is reduced by one. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[out] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of non-deflated eigenvalues, and the order of the */
/* > related secular equation. 0 <= K <=N. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N1 */
/* > \verbatim */
/* > N1 is INTEGER */
/* > The location of the last eigenvalue in the leading sub-matrix. */
/* > min(1,N) <= N1 <= N/2. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, D contains the eigenvalues of the two submatrices to */
/* > be combined. */
/* > On exit, D contains the trailing (N-K) updated eigenvalues */
/* > (those which were deflated) sorted into increasing order. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */
/* > On entry, Q contains the eigenvectors of two submatrices in */
/* > the two square blocks with corners at (1,1), (N1,N1) */
/* > and (N1+1, N1+1), (N,N). */
/* > On exit, Q contains the trailing (N-K) updated eigenvectors */
/* > (those which were deflated) in its last N-K columns. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ */
/* > \verbatim */
/* > LDQ is INTEGER */
/* > The leading dimension of the array Q. LDQ >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in,out] INDXQ */
/* > \verbatim */
/* > INDXQ is INTEGER array, dimension (N) */
/* > The permutation which separately sorts the two sub-problems */
/* > in D into ascending order. Note that elements in the second */
/* > half of this permutation must first have N1 added to their */
/* > values. Destroyed on exit. */
/* > \endverbatim */
/* > */
/* > \param[in,out] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > On entry, the off-diagonal element associated with the rank-1 */
/* > cut which originally split the two submatrices which are now */
/* > being recombined. */
/* > On exit, RHO has been modified to the value required by */
/* > DLAED3. */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension (N) */
/* > On entry, Z contains the updating vector (the last */
/* > row of the first sub-eigenvector matrix and the first row of */
/* > the second sub-eigenvector matrix). */
/* > On exit, the contents of Z have been destroyed by the updating */
/* > process. */
/* > \endverbatim */
/* > */
/* > \param[out] DLAMDA */
/* > \verbatim */
/* > DLAMDA is DOUBLE PRECISION array, dimension (N) */
/* > A copy of the first K eigenvalues which will be used by */
/* > DLAED3 to form the secular equation. */
/* > \endverbatim */
/* > */
/* > \param[out] W */
/* > \verbatim */
/* > W is DOUBLE PRECISION array, dimension (N) */
/* > The first k values of the final deflation-altered z-vector */
/* > which will be passed to DLAED3. */
/* > \endverbatim */
/* > */
/* > \param[out] Q2 */
/* > \verbatim */
/* > Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) */
/* > A copy of the first K eigenvectors which will be used by */
/* > DLAED3 in a matrix multiply (DGEMM) to solve for the new */
/* > eigenvectors. */
/* > \endverbatim */
/* > */
/* > \param[out] INDX */
/* > \verbatim */
/* > INDX is INTEGER array, dimension (N) */
/* > The permutation used to sort the contents of DLAMDA into */
/* > ascending order. */
/* > \endverbatim */
/* > */
/* > \param[out] INDXC */
/* > \verbatim */
/* > INDXC is INTEGER array, dimension (N) */
/* > The permutation used to arrange the columns of the deflated */
/* > Q matrix into three groups: the first group contains non-zero */
/* > elements only at and above N1, the second contains */
/* > non-zero elements only below N1, and the third is dense. */
/* > \endverbatim */
/* > */
/* > \param[out] INDXP */
/* > \verbatim */
/* > INDXP is INTEGER array, dimension (N) */
/* > The permutation used to place deflated values of D at the end */
/* > of the array. INDXP(1:K) points to the nondeflated D-values */
/* > and INDXP(K+1:N) points to the deflated eigenvalues. */
/* > \endverbatim */
/* > */
/* > \param[out] COLTYP */
/* > \verbatim */
/* > COLTYP is INTEGER array, dimension (N) */
/* > During execution, a label which will indicate which of the */
/* > following types a column in the Q2 matrix is: */
/* > 1 : non-zero in the upper half only; */
/* > 2 : dense; */
/* > 3 : non-zero in the lower half only; */
/* > 4 : deflated. */
/* > On exit, COLTYP(i) is the number of columns of type i, */
/* > for i=1 to 4 only. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA \n */
/* > Modified by Francoise Tisseur, University of Tennessee */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal *
d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho,
doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2,
integer *indx, integer *indxc, integer *indxp, integer *coltyp,
integer *info)
int dlaed2_(integer *k, integer *n, integer *n1, doublereal *d__, doublereal *q, integer *ldq,
integer *indxq, doublereal *rho, doublereal *z__, doublereal *dlamda, doublereal *w,
doublereal *q2, integer *indx, integer *indxc, integer *indxp, integer *coltyp,
integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal c__;
integer i__, j;
doublereal s, t;
integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
doublereal eps, tau, tol;
integer psm[4], imax, jmax;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer ctot[4];
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dcopy_(integer *, doublereal *, integer *, doublereal
*, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
@ -309,18 +42,14 @@ f"> */
--indxc;
--indxp;
--coltyp;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
} else if (*ldq < max(1, *n)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MIN */
} else {
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;
}
}
@ -329,66 +58,35 @@ f"> */
xerbla_((char *)"DLAED2", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n2 = *n - *n1;
n1p1 = *n1 + 1;
if (*rho < 0.) {
dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1. Since z is the concatenation of */
/* two normalized vectors, norm2(z) = sqrt(2). */
t = 1. / sqrt(2.);
dscal_(n, &t, &z__[1], &c__1);
/* RHO = ABS( norm(z)**2 * RHO ) */
*rho = (d__1 = *rho * 2., abs(d__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
indxq[i__] += *n1;
/* L10: */
}
/* re-integrate the deflated parts from the last pass */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]];
/* L20: */
}
dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indx[i__] = indxq[indxc[i__]];
/* L30: */
}
/* Calculate the allowable deflation tolerance */
imax = idamax_(n, &z__[1], &c__1);
jmax = idamax_(n, &d__[1], &c__1);
eps = dlamch_((char *)"Epsilon", (ftnlen)7);
/* Computing MAX */
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);
/* If the rank-1 modifier is small enough, no more needs to be done */
/* except to reorganize Q so that its columns correspond with the */
/* elements in D. */
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);
if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
*k = 0;
iq2 = 1;
@ -398,40 +96,25 @@ f"> */
dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
dlamda[j] = d__[i__];
iq2 += *n;
/* L40: */
}
dlacpy_((char *)"A", n, n, &q2[1], n, &q[q_offset], ldq, (ftnlen)1);
dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
goto L190;
}
/* If there are multiple eigenvalues then the problem deflates. Here */
/* the number of equal eigenvalues are found. As each equal */
/* eigenvalue is found, an elementary reflector is computed to rotate */
/* the corresponding eigensubspace so that the corresponding */
/* components of Z are zero in this new basis. */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
/* L50: */
}
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
coltyp[i__] = 3;
/* L60: */
}
*k = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
nj = indx[j];
if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
@ -442,7 +125,6 @@ f"> */
pj = nj;
goto L80;
}
/* L70: */
}
L80:
++j;
@ -451,52 +133,34 @@ L80:
goto L100;
}
if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z__[pj];
c__ = z__[nj];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = dlapy2_(&c__, &s);
t = d__[nj] - d__[pj];
c__ /= tau;
s = -s / tau;
if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
/* Deflation is possible. */
z__[nj] = tau;
z__[pj] = 0.;
if (coltyp[nj] != coltyp[pj]) {
coltyp[nj] = 2;
}
coltyp[pj] = 4;
drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
c__, &s);
/* Computing 2nd power */
drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &c__, &s);
d__1 = c__;
/* Computing 2nd power */
d__2 = s;
t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
/* Computing 2nd power */
d__1 = s;
/* Computing 2nd power */
d__2 = c__;
d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
d__[pj] = t;
--k2;
i__ = 1;
L90:
L90:
if (k2 + i__ <= *n) {
if (d__[pj] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__];
@ -520,42 +184,23 @@ L90:
}
goto L80;
L100:
/* Record the last eigenvalue. */
++(*k);
dlamda[*k] = d__[pj];
w[*k] = z__[pj];
indxp[*k] = pj;
/* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four uniform groups (although one or more of these groups may be */
/* empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L110: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L120: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 1;
psm[1] = ctot[0] + 1;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
*k = *n - ctot[3];
/* Fill out the INDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
js = indxp[j];
@ -563,14 +208,7 @@ L100:
indx[psm[ct - 1]] = js;
indxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L130: */
}
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
/* and Q2 respectively. The eigenvalues/vectors which were not */
/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
/* while those which were deflated go into the last N - K slots. */
i__ = 1;
iq1 = 1;
iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
@ -581,9 +219,7 @@ L100:
z__[i__] = d__[js];
++i__;
iq1 += *n1;
/* L140: */
}
i__1 = ctot[1];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
@ -593,9 +229,7 @@ L100:
++i__;
iq1 += *n1;
iq2 += n2;
/* L150: */
}
i__1 = ctot[2];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
@ -603,9 +237,7 @@ L100:
z__[i__] = d__[js];
++i__;
iq2 += n2;
/* L160: */
}
iq1 = iq2;
i__1 = ctot[3];
for (j = 1; j <= i__1; ++j) {
@ -614,33 +246,18 @@ L100:
iq2 += *n;
z__[i__] = d__[js];
++i__;
/* L170: */
}
/* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */
if (*k < *n) {
dlacpy_((char *)"A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq,
(ftnlen)1);
dlacpy_((char *)"A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq, (ftnlen)1);
i__1 = *n - *k;
dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
}
/* Copy CTOT into COLTYP for referencing in DLAED3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L180: */
}
L190:
return 0;
/* End of DLAED2 */
} /* dlaed2_ */
}
#ifdef __cplusplus
}
}
#endif

347
lib/linalg/dlaed3.cpp
View File

@ -1,268 +1,32 @@
/* fortran/dlaed3.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b22 = 1.;
static doublereal c_b23 = 0.;
/* > \brief \b DLAED3 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Us
ed when the original matrix is tridiagonal. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED3 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed3.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed3.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed3.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, */
/* CTOT, W, S, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDQ, N, N1 */
/* DOUBLE PRECISION RHO */
/* .. */
/* .. Array Arguments .. */
/* INTEGER CTOT( * ), INDX( * ) */
/* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), */
/* $ S( * ), W( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED3 finds the roots of the secular equation, as defined by the */
/* > values in D, W, and RHO, between 1 and K. It makes the */
/* > appropriate calls to DLAED4 and then updates the eigenvectors by */
/* > multiplying the matrix of eigenvectors of the pair of eigensystems */
/* > being combined by the matrix of eigenvectors of the K-by-K system */
/* > which is solved here. */
/* > */
/* > This code makes very mild assumptions about floating point */
/* > arithmetic. It will work on machines with a guard digit in */
/* > add/subtract, or on those binary machines without guard digits */
/* > which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* > It could conceivably fail on hexadecimal or decimal machines */
/* > without guard digits, but we know of none. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of terms in the rational function to be solved by */
/* > DLAED4. K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of rows and columns in the Q matrix. */
/* > N >= K (deflation may result in N>K). */
/* > \endverbatim */
/* > */
/* > \param[in] N1 */
/* > \verbatim */
/* > N1 is INTEGER */
/* > The location of the last eigenvalue in the leading submatrix. */
/* > min(1,N) <= N1 <= N/2. */
/* > \endverbatim */
/* > */
/* > \param[out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > D(I) contains the updated eigenvalues for */
/* > 1 <= I <= K. */
/* > \endverbatim */
/* > */
/* > \param[out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */
/* > Initially the first K columns are used as workspace. */
/* > On output the columns 1 to K contain */
/* > the updated eigenvectors. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ */
/* > \verbatim */
/* > LDQ is INTEGER */
/* > The leading dimension of the array Q. LDQ >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > The value of the parameter in the rank one update equation. */
/* > RHO >= 0 required. */
/* > \endverbatim */
/* > */
/* > \param[in,out] DLAMDA */
/* > \verbatim */
/* > DLAMDA is DOUBLE PRECISION array, dimension (K) */
/* > The first K elements of this array contain the old roots */
/* > of the deflated updating problem. These are the poles */
/* > of the secular equation. May be changed on output by */
/* > having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
/* > Cray-2, or Cray C-90, as described above. */
/* > \endverbatim */
/* > */
/* > \param[in] Q2 */
/* > \verbatim */
/* > Q2 is DOUBLE PRECISION array, dimension (LDQ2*N) */
/* > The first K columns of this matrix contain the non-deflated */
/* > eigenvectors for the split problem. */
/* > \endverbatim */
/* > */
/* > \param[in] INDX */
/* > \verbatim */
/* > INDX is INTEGER array, dimension (N) */
/* > The permutation used to arrange the columns of the deflated */
/* > Q matrix into three groups (see DLAED2). */
/* > The rows of the eigenvectors found by DLAED4 must be likewise */
/* > permuted before the matrix multiply can take place. */
/* > \endverbatim */
/* > */
/* > \param[in] CTOT */
/* > \verbatim */
/* > CTOT is INTEGER array, dimension (4) */
/* > A count of the total number of the various types of columns */
/* > in Q, as described in INDX. The fourth column type is any */
/* > column which has been deflated. */
/* > \endverbatim */
/* > */
/* > \param[in,out] W */
/* > \verbatim */
/* > W is DOUBLE PRECISION array, dimension (K) */
/* > The first K elements of this array contain the components */
/* > of the deflation-adjusted updating vector. Destroyed on */
/* > output. */
/* > \endverbatim */
/* > */
/* > \param[out] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION array, dimension (N1 + 1)*K */
/* > Will contain the eigenvectors of the repaired matrix which */
/* > will be multiplied by the previously accumulated eigenvectors */
/* > to update the system. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: if INFO = 1, an eigenvalue did not converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA \n */
/* > Modified by Francoise Tisseur, University of Tennessee */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal *
d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda,
doublereal *q2, integer *indx, integer *ctot, doublereal *w,
doublereal *s, integer *info)
int dlaed3_(integer *k, integer *n, integer *n1, doublereal *d__, doublereal *q, integer *ldq,
doublereal *rho, doublereal *dlamda, doublereal *q2, integer *indx, integer *ctot,
doublereal *w, doublereal *s, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j, n2, n12, ii, n23, iq2;
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer
*), dlaed4_(integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dlaed4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
@ -273,15 +37,12 @@ f"> */
--ctot;
--w;
--s;
/* Function Body */
*info = 0;
if (*k < 0) {
*info = -1;
} else if (*n < *k) {
*info = -2;
} else if (*ldq < max(1,*n)) {
} else if (*ldq < max(1, *n)) {
*info = -6;
}
if (*info != 0) {
@ -289,49 +50,20 @@ f"> */
xerbla_((char *)"DLAED3", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*k == 0) {
return 0;
}
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DLAMDA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */
}
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
info);
/* If the zero finder fails, the computation is terminated. */
dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], info);
if (*info != 0) {
goto L120;
}
/* L20: */
}
if (*k == 1) {
goto L110;
}
@ -344,17 +76,10 @@ f"> */
q[j * q_dim1 + 1] = w[ii];
ii = indx[2];
q[j * q_dim1 + 2] = w[ii];
/* L30: */
}
goto L110;
}
/* Compute updated W. */
dcopy_(k, &w[1], &c__1, &s[1], &c__1);
/* Initialize W(I) = Q(I,I) */
i__1 = *ldq + 1;
dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
i__1 = *k;
@ -362,76 +87,52 @@ f"> */
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L40: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L50: */
}
/* L60: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = sqrt(-w[i__]);
w[i__] = d_lmp_sign(&d__1, &s[i__]);
/* L70: */
}
/* Compute eigenvectors of the modified rank-1 modification. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
s[i__] = w[i__] / q[i__ + j * q_dim1];
/* L80: */
}
temp = dnrm2_(k, &s[1], &c__1);
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
ii = indx[i__];
q[i__ + j * q_dim1] = s[ii] / temp;
/* L90: */
}
/* L100: */
}
/* Compute the updated eigenvectors. */
L110:
n2 = *n - *n1;
n12 = ctot[1] + ctot[2];
n23 = ctot[2] + ctot[3];
dlacpy_((char *)"A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23, (ftnlen)
1);
dlacpy_((char *)"A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23, (ftnlen)1);
iq2 = *n1 * n12 + 1;
if (n23 != 0) {
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);
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);
} else {
dlaset_((char *)"A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq, (
ftnlen)1);
dlaset_((char *)"A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq, (ftnlen)1);
}
dlacpy_((char *)"A", &n12, k, &q[q_offset], ldq, &s[1], &n12, (ftnlen)1);
if (n12 != 0) {
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);
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);
} else {
dlaset_((char *)"A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq, (ftnlen)1);
}
L120:
return 0;
/* End of DLAED3 */
} /* dlaed3_ */
}
#ifdef __cplusplus
}
}
#endif

595
lib/linalg/dlaed4.cpp
View File

File diff suppressed because it is too large Load Diff

169
lib/linalg/dlaed5.cpp
View File

@ -1,176 +1,22 @@
/* fortran/dlaed5.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAED5 used by DSTEDC. Solves the 2-by-2 secular equation. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED5 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed5.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed5.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed5.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) */
/* .. Scalar Arguments .. */
/* INTEGER I */
/* DOUBLE PRECISION DLAM, RHO */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > This subroutine computes the I-th eigenvalue of a symmetric rank-one */
/* > modification of a 2-by-2 diagonal matrix */
/* > */
/* > diag( D ) + RHO * Z * transpose(Z) . */
/* > */
/* > The diagonal elements in the array D are assumed to satisfy */
/* > */
/* > D(i) < D(j) for i < j . */
/* > */
/* > We also assume RHO > 0 and that the Euclidean norm of the vector */
/* > Z is one. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] I */
/* > \verbatim */
/* > I is INTEGER */
/* > The index of the eigenvalue to be computed. I = 1 or I = 2. */
/* > \endverbatim */
/* > */
/* > \param[in] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (2) */
/* > The original eigenvalues. We assume D(1) < D(2). */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension (2) */
/* > The components of the updating vector. */
/* > \endverbatim */
/* > */
/* > \param[out] DELTA */
/* > \verbatim */
/* > DELTA is DOUBLE PRECISION array, dimension (2) */
/* > The vector DELTA contains the information necessary */
/* > to construct the eigenvectors. */
/* > \endverbatim */
/* > */
/* > \param[in] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > The scalar in the symmetric updating formula. */
/* > \endverbatim */
/* > */
/* > \param[out] DLAM */
/* > \verbatim */
/* > DLAM is DOUBLE PRECISION */
/* > The computed lambda_I, the I-th updated eigenvalue. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ren-Cang Li, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__,
doublereal *delta, doublereal *rho, doublereal *dlam)
int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, doublereal *delta, doublereal *rho,
doublereal *dlam)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal b, c__, w, del, tau, temp;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--delta;
--z__;
--d__;
/* Function Body */
del = d__[2] - d__[1];
if (*i__ == 1) {
w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.;
if (w > 0.) {
b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[1] * z__[1] * del;
/* B > ZERO, always */
tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
*dlam = d__[1] + tau;
delta[1] = -z__[1] / tau;
@ -191,9 +37,6 @@ f"> */
delta[1] /= temp;
delta[2] /= temp;
} else {
/* Now I=2 */
b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * del;
if (b > 0.) {
@ -209,11 +52,7 @@ f"> */
delta[2] /= temp;
}
return 0;
/* End of DLAED5 */
} /* dlaed5_ */
}
#ifdef __cplusplus
}
}
#endif

296
lib/linalg/dlaed6.cpp
View File

@ -1,173 +1,13 @@
/* fortran/dlaed6.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAED6 used by DSTEDC. Computes one Newton step in solution of the secular equation. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED6 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed6.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed6.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed6.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) */
/* .. Scalar Arguments .. */
/* LOGICAL ORGATI */
/* INTEGER INFO, KNITER */
/* DOUBLE PRECISION FINIT, RHO, TAU */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( 3 ), Z( 3 ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED6 computes the positive or negative root (closest to the origin) */
/* > of */
/* > z(1) z(2) z(3) */
/* > f(x) = rho + --------- + ---------- + --------- */
/* > d(1)-x d(2)-x d(3)-x */
/* > */
/* > It is assumed that */
/* > */
/* > if ORGATI = .true. the root is between d(2) and d(3); */
/* > otherwise it is between d(1) and d(2) */
/* > */
/* > This routine will be called by DLAED4 when necessary. In most cases, */
/* > the root sought is the smallest in magnitude, though it might not be */
/* > in some extremely rare situations. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] KNITER */
/* > \verbatim */
/* > KNITER is INTEGER */
/* > Refer to DLAED4 for its significance. */
/* > \endverbatim */
/* > */
/* > \param[in] ORGATI */
/* > \verbatim */
/* > ORGATI is LOGICAL */
/* > If ORGATI is true, the needed root is between d(2) and */
/* > d(3); otherwise it is between d(1) and d(2). See */
/* > DLAED4 for further details. */
/* > \endverbatim */
/* > */
/* > \param[in] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > Refer to the equation f(x) above. */
/* > \endverbatim */
/* > */
/* > \param[in] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (3) */
/* > D satisfies d(1) < d(2) < d(3). */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension (3) */
/* > Each of the elements in z must be positive. */
/* > \endverbatim */
/* > */
/* > \param[in] FINIT */
/* > \verbatim */
/* > FINIT is DOUBLE PRECISION */
/* > The value of f at 0. It is more accurate than the one */
/* > evaluated inside this routine (if someone wants to do */
/* > so). */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION */
/* > The root of the equation f(x). */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > > 0: if INFO = 1, failure to converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > 10/02/03: This version has a few statements commented out for thread */
/* > safety (machine parameters are computed on each entry). SJH. */
/* > */
/* > 05/10/06: Modified from a new version of Ren-Cang Li, use */
/* > Gragg-Thornton-Warner cubic convergent scheme for better stability. */
/* > \endverbatim */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ren-Cang Li, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal *
rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal *
tau, integer *info)
int dlaed6_(integer *kniter, logical *orgati, doublereal *rho, doublereal *d__, doublereal *z__,
doublereal *finit, doublereal *tau, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal), log(doublereal), pow_lmp_di(doublereal *, integer *);
/* Local variables */
doublereal a, b, c__, f;
integer i__;
doublereal fc, df, ddf, lbd, eta, ubd, eps, base;
@ -178,38 +18,9 @@ f"> */
doublereal small1, small2, sminv1, sminv2;
extern doublereal dlamch_(char *, ftnlen);
doublereal dscale[3], sclfac, zscale[3], erretm, sclinv;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
--d__;
/* Function Body */
*info = 0;
if (*orgati) {
lbd = d__[2];
ubd = d__[3];
@ -222,7 +33,6 @@ f"> */
} else {
ubd = 0.;
}
niter = 1;
*tau = 0.;
if (*kniter == 2) {
@ -237,20 +47,17 @@ f"> */
a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2];
b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1];
}
/* Computing MAX */
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);
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);
a /= temp;
b /= temp;
c__ /= temp;
if (c__ == 0.) {
*tau = b / a;
} else if (a <= 0.) {
*tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
c__ * 2.);
*tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.);
} 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) {
*tau = (lbd + ubd) / 2.;
@ -258,9 +65,9 @@ f"> */
if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) {
*tau = 0.;
} else {
temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau
* z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / (
d__[3] * (d__[3] - *tau));
temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) +
*tau * z__[2] / (d__[2] * (d__[2] - *tau)) +
*tau * z__[3] / (d__[3] * (d__[3] - *tau));
if (temp <= 0.) {
lbd = *tau;
} else {
@ -271,73 +78,43 @@ f"> */
}
}
}
/* get machine parameters for possible scaling to avoid overflow */
/* modified by Sven: parameters SMALL1, SMINV1, SMALL2, */
/* SMINV2, EPS are not SAVEd anymore between one call to the */
/* others but recomputed at each call */
eps = dlamch_((char *)"Epsilon", (ftnlen)7);
base = dlamch_((char *)"Base", (ftnlen)4);
i__1 = (integer) (log(dlamch_((char *)"SafMin", (ftnlen)6)) / log(base) / 3.);
i__1 = (integer)(log(dlamch_((char *)"SafMin", (ftnlen)6)) / log(base) / 3.);
small1 = pow_lmp_di(&base, &i__1);
sminv1 = 1. / small1;
small2 = small1 * small1;
sminv2 = sminv1 * sminv1;
/* Determine if scaling of inputs necessary to avoid overflow */
/* when computing 1/TEMP**3 */
if (*orgati) {
/* Computing MIN */
d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - *
tau, abs(d__2));
temp = min(d__3,d__4);
d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - *tau, abs(d__2));
temp = min(d__3, d__4);
} else {
/* Computing MIN */
d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - *
tau, abs(d__2));
temp = min(d__3,d__4);
d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - *tau, abs(d__2));
temp = min(d__3, d__4);
}
scale = FALSE_;
if (temp <= small1) {
scale = TRUE_;
if (temp <= small2) {
/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */
sclfac = sminv2;
sclinv = small2;
} else {
/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */
sclfac = sminv1;
sclinv = small1;
}
/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */
for (i__ = 1; i__ <= 3; ++i__) {
dscale[i__ - 1] = d__[i__] * sclfac;
zscale[i__ - 1] = z__[i__] * sclfac;
/* L10: */
}
*tau *= sclfac;
lbd *= sclfac;
ubd *= sclfac;
} else {
/* Copy D and Z to DSCALE and ZSCALE */
for (i__ = 1; i__ <= 3; ++i__) {
dscale[i__ - 1] = d__[i__];
zscale[i__ - 1] = z__[i__];
/* L20: */
}
}
fc = 0.;
df = 0.;
ddf = 0.;
@ -349,10 +126,8 @@ f"> */
fc += temp1 / dscale[i__ - 1];
df += temp2;
ddf += temp3;
/* L30: */
}
f = *finit + *tau * fc;
if (abs(f) <= 0.) {
goto L60;
}
@ -361,22 +136,8 @@ f"> */
} else {
ubd = *tau;
}
/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */
/* scheme */
/* It is not hard to see that */
/* 1) Iterations will go up monotonically */
/* if FINIT < 0; */
/* 2) Iterations will go down monotonically */
/* if FINIT > 0. */
iter = niter + 1;
for (niter = iter; niter <= 40; ++niter) {
if (*orgati) {
temp1 = dscale[1] - *tau;
temp2 = dscale[2] - *tau;
@ -387,30 +148,25 @@ f"> */
a = (temp1 + temp2) * f - temp1 * temp2 * df;
b = temp1 * temp2 * f;
c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf;
/* Computing MAX */
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);
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);
a /= temp;
b /= temp;
c__ /= temp;
if (c__ == 0.) {
eta = b / a;
} else if (a <= 0.) {
eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__
* 2.);
eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.);
} 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.) {
eta = -f / df;
}
*tau += eta;
if (*tau < lbd || *tau > ubd) {
*tau = (lbd + ubd) / 2.;
}
fc = 0.;
erretm = 0.;
df = 0.;
@ -429,12 +185,10 @@ f"> */
} else {
goto L60;
}
/* L40: */
}
f = *finit + *tau * fc;
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;
}
if (f <= 0.) {
@ -442,22 +196,14 @@ f"> */
} else {
ubd = *tau;
}
/* L50: */
}
*info = 1;
L60:
/* Undo scaling */
if (scale) {
*tau *= sclinv;
}
return 0;
/* End of DLAED6 */
} /* dlaed6_ */
}
#ifdef __cplusplus
}
}
#endif

418
lib/linalg/dlaed7.cpp
View File

@ -1,348 +1,38 @@
/* fortran/dlaed7.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
static doublereal c_b10 = 1.;
static doublereal c_b11 = 0.;
static integer c_n1 = -1;
/* > \brief \b DLAED7 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification
by a rank-one symmetric matrix. Used when the original matrix is dense. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED7 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed7.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed7.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed7.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, */
/* LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, */
/* PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, */
/* INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, */
/* $ QSIZ, TLVLS */
/* DOUBLE PRECISION RHO */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), */
/* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) */
/* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), */
/* $ QSTORE( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED7 computes the updated eigensystem of a diagonal */
/* > matrix after modification by a rank-one symmetric matrix. This */
/* > routine is used only for the eigenproblem which requires all */
/* > eigenvalues and optionally eigenvectors of a dense symmetric matrix */
/* > that has been reduced to tridiagonal form. DLAED1 handles */
/* > the case in which all eigenvalues and eigenvectors of a symmetric */
/* > tridiagonal matrix are desired. */
/* > */
/* > T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) */
/* > */
/* > where Z = Q**Tu, u is a vector of length N with ones in the */
/* > CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
/* > */
/* > The eigenvectors of the original matrix are stored in Q, and the */
/* > eigenvalues are in D. The algorithm consists of three stages: */
/* > */
/* > The first stage consists of deflating the size of the problem */
/* > when there are multiple eigenvalues or if there is a zero in */
/* > the Z vector. For each such occurrence the dimension of the */
/* > secular equation problem is reduced by one. This stage is */
/* > performed by the routine DLAED8. */
/* > */
/* > The second stage consists of calculating the updated */
/* > eigenvalues. This is done by finding the roots of the secular */
/* > equation via the routine DLAED4 (as called by DLAED9). */
/* > This routine also calculates the eigenvectors of the current */
/* > problem. */
/* > */
/* > The final stage consists of computing the updated eigenvectors */
/* > directly using the updated eigenvalues. The eigenvectors for */
/* > the current problem are multiplied with the eigenvectors from */
/* > the overall problem. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > = 0: Compute eigenvalues only. */
/* > = 1: Compute eigenvectors of original dense symmetric matrix */
/* > also. On entry, Q contains the orthogonal matrix used */
/* > to reduce the original matrix to tridiagonal form. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] QSIZ */
/* > \verbatim */
/* > QSIZ is INTEGER */
/* > The dimension of the orthogonal matrix used to reduce */
/* > the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
/* > \endverbatim */
/* > */
/* > \param[in] TLVLS */
/* > \verbatim */
/* > TLVLS is INTEGER */
/* > The total number of merging levels in the overall divide and */
/* > conquer tree. */
/* > \endverbatim */
/* > */
/* > \param[in] CURLVL */
/* > \verbatim */
/* > CURLVL is INTEGER */
/* > The current level in the overall merge routine, */
/* > 0 <= CURLVL <= TLVLS. */
/* > \endverbatim */
/* > */
/* > \param[in] CURPBM */
/* > \verbatim */
/* > CURPBM is INTEGER */
/* > The current problem in the current level in the overall */
/* > merge routine (counting from upper left to lower right). */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, the eigenvalues of the rank-1-perturbed matrix. */
/* > On exit, the eigenvalues of the repaired matrix. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */
/* > On entry, the eigenvectors of the rank-1-perturbed matrix. */
/* > On exit, the eigenvectors of the repaired tridiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ */
/* > \verbatim */
/* > LDQ is INTEGER */
/* > The leading dimension of the array Q. LDQ >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[out] INDXQ */
/* > \verbatim */
/* > INDXQ is INTEGER array, dimension (N) */
/* > The permutation which will reintegrate the subproblem just */
/* > solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) */
/* > will be in ascending order. */
/* > \endverbatim */
/* > */
/* > \param[in] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > The subdiagonal element used to create the rank-1 */
/* > modification. */
/* > \endverbatim */
/* > */
/* > \param[in] CUTPNT */
/* > \verbatim */
/* > CUTPNT is INTEGER */
/* > Contains the location of the last eigenvalue in the leading */
/* > sub-matrix. min(1,N) <= CUTPNT <= N. */
/* > \endverbatim */
/* > */
/* > \param[in,out] QSTORE */
/* > \verbatim */
/* > QSTORE is DOUBLE PRECISION array, dimension (N**2+1) */
/* > Stores eigenvectors of submatrices encountered during */
/* > divide and conquer, packed together. QPTR points to */
/* > beginning of the submatrices. */
/* > \endverbatim */
/* > */
/* > \param[in,out] QPTR */
/* > \verbatim */
/* > QPTR is INTEGER array, dimension (N+2) */
/* > List of indices pointing to beginning of submatrices stored */
/* > in QSTORE. The submatrices are numbered starting at the */
/* > bottom left of the divide and conquer tree, from left to */
/* > right and bottom to top. */
/* > \endverbatim */
/* > */
/* > \param[in] PRMPTR */
/* > \verbatim */
/* > PRMPTR is INTEGER array, dimension (N lg N) */
/* > Contains a list of pointers which indicate where in PERM a */
/* > level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
/* > indicates the size of the permutation and also the size of */
/* > the full, non-deflated problem. */
/* > \endverbatim */
/* > */
/* > \param[in] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, dimension (N lg N) */
/* > Contains the permutations (from deflation and sorting) to be */
/* > applied to each eigenblock. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER array, dimension (N lg N) */
/* > Contains a list of pointers which indicate where in GIVCOL a */
/* > level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
/* > indicates the number of Givens rotations. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, dimension (2, N lg N) */
/* > Each pair of numbers indicates a pair of columns to take place */
/* > in a Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) */
/* > Each number indicates the S value to be used in the */
/* > corresponding Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N) */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension (4*N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: if INFO = 1, an eigenvalue did not converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* ===================================================================== */
/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz,
integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__,
doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer
*cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer *
perm, integer *givptr, integer *givcol, doublereal *givnum,
doublereal *work, integer *iwork, integer *info)
int dlaed7_(integer *icompq, integer *n, integer *qsiz, integer *tlvls, integer *curlvl,
integer *curpbm, doublereal *d__, doublereal *q, integer *ldq, integer *indxq,
doublereal *rho, integer *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr,
integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
/* Builtin functions */
integer pow_lmp_ii(integer *, integer *);
/* Local variables */
integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer indxc, indxp;
extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *), dlaed9_(integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dlaeda_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, doublereal *, integer *, doublereal *, doublereal *, integer *)
;
extern int dlaed8_(integer *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *),
dlaed9_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *),
dlaeda_(integer *, integer *, integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
integer idlmda;
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen);
extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *),
xerbla_(char *, integer *, ftnlen);
integer coltyp;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
@ -357,19 +47,16 @@ f"> */
givnum -= 3;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*icompq == 1 && *qsiz < *n) {
*info = -3;
} else if (*ldq < max(1,*n)) {
} else if (*ldq < max(1, *n)) {
*info = -9;
} else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
} else if (min(1, *n) > *cutpnt || *n < *cutpnt) {
*info = -12;
}
if (*info != 0) {
@ -377,88 +64,55 @@ f"> */
xerbla_((char *)"DLAED7", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* The following values are for bookkeeping purposes only. They are */
/* integer pointers which indicate the portion of the workspace */
/* used by a particular array in DLAED8 and DLAED9. */
if (*icompq == 1) {
ldq2 = *qsiz;
} else {
ldq2 = *n;
}
iz = 1;
idlmda = iz + *n;
iw = idlmda + *n;
iq2 = iw + *n;
is = iq2 + *n * ldq2;
indx = 1;
indxc = indx + *n;
coltyp = indxc + *n;
indxp = coltyp + *n;
/* Form the z-vector which consists of the last row of Q_1 and the */
/* first row of Q_2. */
ptr = pow_lmp_ii(&c__2, tlvls) + 1;
i__1 = *curlvl - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *tlvls - i__;
ptr += pow_lmp_ii(&c__2, &i__2);
/* L10: */
}
curr = ptr + *curpbm;
dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz
+ *n], info);
/* When solving the final problem, we no longer need the stored data, */
/* so we will overwrite the data from this level onto the previously */
/* used storage space. */
dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &givcol[3], &givnum[3],
&qstore[1], &qptr[1], &work[iz], &work[iz + *n], info);
if (*curlvl == *tlvls) {
qptr[curr] = 1;
prmptr[curr] = 1;
givptr[curr] = 1;
}
/* Sort and Deflate eigenvalues. */
dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho,
cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], &
perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1)
+ 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[
indx], info);
dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, cutpnt, &work[iz],
&work[idlmda], &work[iq2], &ldq2, &work[iw], &perm[prmptr[curr]], &givptr[curr + 1],
&givcol[(givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp],
&iwork[indx], info);
prmptr[curr + 1] = prmptr[curr] + *n;
givptr[curr + 1] += givptr[curr];
/* Solve Secular Equation. */
if (k != 0) {
dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda],
&work[iw], &qstore[qptr[curr]], &k, info);
dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], &work[iw],
&qstore[qptr[curr]], &k, info);
if (*info != 0) {
goto L30;
}
if (*icompq == 1) {
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, (
ftnlen)1);
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, (ftnlen)1);
}
/* Computing 2nd power */
i__1 = k;
qptr[curr + 1] = qptr[curr] + i__1 * i__1;
/* Prepare the INDXQ sorting permutation. */
n1 = k;
n2 = *n - k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
@ -467,17 +121,11 @@ f"> */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indxq[i__] = i__;
/* L20: */
}
}
L30:
return 0;
/* End of DLAED7 */
} /* dlaed7_ */
}
#ifdef __cplusplus
}
}
#endif

434
lib/linalg/dlaed8.cpp
View File

@ -1,329 +1,34 @@
/* fortran/dlaed8.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b3 = -1.;
static integer c__1 = 1;
/* > \brief \b DLAED8 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original
matrix is dense. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED8 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed8.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed8.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed8.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, */
/* CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, */
/* GIVCOL, GIVNUM, INDXP, INDX, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, */
/* $ QSIZ */
/* DOUBLE PRECISION RHO */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), */
/* $ INDXQ( * ), PERM( * ) */
/* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), */
/* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED8 merges the two sets of eigenvalues together into a single */
/* > sorted set. Then it tries to deflate the size of the problem. */
/* > There are two ways in which deflation can occur: when two or more */
/* > eigenvalues are close together or if there is a tiny element in the */
/* > Z vector. For each such occurrence the order of the related secular */
/* > equation problem is reduced by one. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > = 0: Compute eigenvalues only. */
/* > = 1: Compute eigenvectors of original dense symmetric matrix */
/* > also. On entry, Q contains the orthogonal matrix used */
/* > to reduce the original matrix to tridiagonal form. */
/* > \endverbatim */
/* > */
/* > \param[out] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of non-deflated eigenvalues, and the order of the */
/* > related secular equation. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] QSIZ */
/* > \verbatim */
/* > QSIZ is INTEGER */
/* > The dimension of the orthogonal matrix used to reduce */
/* > the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, the eigenvalues of the two submatrices to be */
/* > combined. On exit, the trailing (N-K) updated eigenvalues */
/* > (those which were deflated) sorted into increasing order. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */
/* > If ICOMPQ = 0, Q is not referenced. Otherwise, */
/* > on entry, Q contains the eigenvectors of the partially solved */
/* > system which has been previously updated in matrix */
/* > multiplies with other partially solved eigensystems. */
/* > On exit, Q contains the trailing (N-K) updated eigenvectors */
/* > (those which were deflated) in its last N-K columns. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ */
/* > \verbatim */
/* > LDQ is INTEGER */
/* > The leading dimension of the array Q. LDQ >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] INDXQ */
/* > \verbatim */
/* > INDXQ is INTEGER array, dimension (N) */
/* > The permutation which separately sorts the two sub-problems */
/* > in D into ascending order. Note that elements in the second */
/* > half of this permutation must first have CUTPNT added to */
/* > their values in order to be accurate. */
/* > \endverbatim */
/* > */
/* > \param[in,out] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > On entry, the off-diagonal element associated with the rank-1 */
/* > cut which originally split the two submatrices which are now */
/* > being recombined. */
/* > On exit, RHO has been modified to the value required by */
/* > DLAED3. */
/* > \endverbatim */
/* > */
/* > \param[in] CUTPNT */
/* > \verbatim */
/* > CUTPNT is INTEGER */
/* > The location of the last eigenvalue in the leading */
/* > sub-matrix. min(1,N) <= CUTPNT <= N. */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension (N) */
/* > On entry, Z contains the updating vector (the last row of */
/* > the first sub-eigenvector matrix and the first row of the */
/* > second sub-eigenvector matrix). */
/* > On exit, the contents of Z are destroyed by the updating */
/* > process. */
/* > \endverbatim */
/* > */
/* > \param[out] DLAMDA */
/* > \verbatim */
/* > DLAMDA is DOUBLE PRECISION array, dimension (N) */
/* > A copy of the first K eigenvalues which will be used by */
/* > DLAED3 to form the secular equation. */
/* > \endverbatim */
/* > */
/* > \param[out] Q2 */
/* > \verbatim */
/* > Q2 is DOUBLE PRECISION array, dimension (LDQ2,N) */
/* > If ICOMPQ = 0, Q2 is not referenced. Otherwise, */
/* > a copy of the first K eigenvectors which will be used by */
/* > DLAED7 in a matrix multiply (DGEMM) to update the new */
/* > eigenvectors. */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ2 */
/* > \verbatim */
/* > LDQ2 is INTEGER */
/* > The leading dimension of the array Q2. LDQ2 >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[out] W */
/* > \verbatim */
/* > W is DOUBLE PRECISION array, dimension (N) */
/* > The first k values of the final deflation-altered z-vector and */
/* > will be passed to DLAED3. */
/* > \endverbatim */
/* > */
/* > \param[out] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, dimension (N) */
/* > The permutations (from deflation and sorting) to be applied */
/* > to each eigenblock. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER */
/* > The number of Givens rotations which took place in this */
/* > subproblem. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, dimension (2, N) */
/* > Each pair of numbers indicates a pair of columns to take place */
/* > in a Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, dimension (2, N) */
/* > Each number indicates the S value to be used in the */
/* > corresponding Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[out] INDXP */
/* > \verbatim */
/* > INDXP is INTEGER array, dimension (N) */
/* > The permutation used to place deflated values of D at the end */
/* > of the array. INDXP(1:K) points to the nondeflated D-values */
/* > and INDXP(K+1:N) points to the deflated eigenvalues. */
/* > \endverbatim */
/* > */
/* > \param[out] INDX */
/* > \verbatim */
/* > INDX is INTEGER array, dimension (N) */
/* > The permutation used to sort the contents of D into ascending */
/* > order. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* ===================================================================== */
/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer
*qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq,
doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda,
doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer
*givptr, integer *givcol, doublereal *givnum, integer *indxp, integer
*indx, integer *info)
int dlaed8_(integer *icompq, integer *k, integer *n, integer *qsiz, doublereal *d__, doublereal *q,
integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, doublereal *z__,
doublereal *dlamda, doublereal *q2, integer *ldq2, doublereal *w, integer *perm,
integer *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer *indx,
integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal c__;
integer i__, j;
doublereal s, t;
integer k2, n1, n2, jp, n1p1;
doublereal eps, tau, tol;
integer jlam, imax, jmax;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dscal_(
integer *, doublereal *, doublereal *, integer *), dcopy_(integer
*, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *),
dscal_(integer *, doublereal *, doublereal *, integer *),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
@ -340,21 +45,18 @@ f"> */
givnum -= 3;
--indxp;
--indx;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*n < 0) {
*info = -3;
} else if (*icompq == 1 && *qsiz < *n) {
*info = -4;
} else if (*ldq < max(1,*n)) {
} else if (*ldq < max(1, *n)) {
*info = -7;
} else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
} else if (*cutpnt < min(1, *n) || *cutpnt > *n) {
*info = -10;
} else if (*ldq2 < max(1,*n)) {
} else if (*ldq2 < max(1, *n)) {
*info = -14;
}
if (*info != 0) {
@ -362,51 +64,31 @@ f"> */
xerbla_((char *)"DLAED8", &i__1, (ftnlen)6);
return 0;
}
/* Need to initialize GIVPTR to O here in case of quick exit */
/* to prevent an unspecified code behavior (usually sigfault) */
/* when IWORK array on entry to *stedc is not zeroed */
/* (or at least some IWORK entries which used in *laed7 for GIVPTR). */
*givptr = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n1 = *cutpnt;
n2 = *n - n1;
n1p1 = n1 + 1;
if (*rho < 0.) {
dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1 */
t = 1. / sqrt(2.);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
indx[j] = j;
/* L10: */
}
dscal_(n, &t, &z__[1], &c__1);
*rho = (d__1 = *rho * 2., abs(d__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
indxq[i__] += *cutpnt;
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]];
w[i__] = z__[indxq[i__]];
/* L30: */
}
i__ = 1;
j = *cutpnt + 1;
@ -415,56 +97,33 @@ f"> */
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = dlamda[indx[i__]];
z__[i__] = w[indx[i__]];
/* L40: */
}
/* Calculate the allowable deflation tolerance */
imax = idamax_(n, &z__[1], &c__1);
jmax = idamax_(n, &d__[1], &c__1);
eps = dlamch_((char *)"Epsilon", (ftnlen)7);
tol = eps * 8. * (d__1 = d__[jmax], abs(d__1));
/* If the rank-1 modifier is small enough, no more needs to be done */
/* except to reorganize Q so that its columns correspond with the */
/* elements in D. */
if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
*k = 0;
if (*icompq == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]];
/* L50: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]];
dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1
+ 1], &c__1);
/* L60: */
dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &c__1);
}
dlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq,
(ftnlen)1);
dlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, (ftnlen)1);
}
return 0;
}
/* If there are multiple eigenvalues then the problem deflates. Here */
/* the number of equal eigenvalues are found. As each equal */
/* eigenvalue is found, an elementary reflector is computed to rotate */
/* the corresponding eigensubspace so that the corresponding */
/* components of Z are zero in this new basis. */
*k = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
if (j == *n) {
@ -474,7 +133,6 @@ f"> */
jlam = j;
goto L80;
}
/* L70: */
}
L80:
++j;
@ -482,49 +140,33 @@ L80:
goto L100;
}
if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z__[jlam];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = dlapy2_(&c__, &s);
t = d__[j] - d__[jlam];
c__ /= tau;
s = -s / tau;
if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
/* Deflation is possible. */
z__[j] = tau;
z__[jlam] = 0.;
/* Record the appropriate Givens rotation */
++(*givptr);
givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
givcol[(*givptr << 1) + 2] = indxq[indx[j]];
givnum[(*givptr << 1) + 1] = c__;
givnum[(*givptr << 1) + 2] = s;
if (*icompq == 1) {
drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[
indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1,
&q[indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
}
t = d__[jlam] * c__ * c__ + d__[j] * s * s;
d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
d__[jlam] = t;
--k2;
i__ = 1;
L90:
L90:
if (k2 + i__ <= *n) {
if (d__[jlam] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__];
@ -548,28 +190,17 @@ L90:
}
goto L80;
L100:
/* Record the last eigenvalue. */
++(*k);
w[*k] = z__[jlam];
dlamda[*k] = d__[jlam];
indxp[*k] = jlam;
L110:
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
/* and Q2 respectively. The eigenvalues/vectors which were not */
/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
/* while those which were deflated go into the last N - K slots. */
if (*icompq == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jp = indxp[j];
dlamda[j] = d__[jp];
perm[j] = indxq[indx[jp]];
/* L120: */
}
} else {
i__1 = *n;
@ -577,15 +208,9 @@ L110:
jp = indxp[j];
dlamda[j] = d__[jp];
perm[j] = indxq[indx[jp]];
dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
, &c__1);
/* L130: */
dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &c__1);
}
}
/* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */
if (*k < *n) {
if (*icompq == 0) {
i__1 = *n - *k;
@ -594,17 +219,12 @@ L110:
i__1 = *n - *k;
dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = *n - *k;
dlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*
k + 1) * q_dim1 + 1], ldq, (ftnlen)1);
dlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k + 1) * q_dim1 + 1],
ldq, (ftnlen)1);
}
}
return 0;
/* End of DLAED8 */
} /* dlaed8_ */
}
#ifdef __cplusplus
}
}
#endif

289
lib/linalg/dlaed9.cpp
View File

@ -1,229 +1,23 @@
/* fortran/dlaed9.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DLAED9 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Us
ed when the original matrix is dense. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAED9 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaed9.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaed9.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaed9.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, */
/* S, LDS, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N */
/* DOUBLE PRECISION RHO */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), */
/* $ W( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAED9 finds the roots of the secular equation, as defined by the */
/* > values in D, Z, and RHO, between KSTART and KSTOP. It makes the */
/* > appropriate calls to DLAED4 and then stores the new matrix of */
/* > eigenvectors for use in calculating the next level of Z vectors. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of terms in the rational function to be solved by */
/* > DLAED4. K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] KSTART */
/* > \verbatim */
/* > KSTART is INTEGER */
/* > \endverbatim */
/* > */
/* > \param[in] KSTOP */
/* > \verbatim */
/* > KSTOP is INTEGER */
/* > The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP */
/* > are to be computed. 1 <= KSTART <= KSTOP <= K. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of rows and columns in the Q matrix. */
/* > N >= K (delation may result in N > K). */
/* > \endverbatim */
/* > */
/* > \param[out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > D(I) contains the updated eigenvalues */
/* > for KSTART <= I <= KSTOP. */
/* > \endverbatim */
/* > */
/* > \param[out] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */
/* > \endverbatim */
/* > */
/* > \param[in] LDQ */
/* > \verbatim */
/* > LDQ is INTEGER */
/* > The leading dimension of the array Q. LDQ >= max( 1, N ). */
/* > \endverbatim */
/* > */
/* > \param[in] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > The value of the parameter in the rank one update equation. */
/* > RHO >= 0 required. */
/* > \endverbatim */
/* > */
/* > \param[in] DLAMDA */
/* > \verbatim */
/* > DLAMDA is DOUBLE PRECISION array, dimension (K) */
/* > The first K elements of this array contain the old roots */
/* > of the deflated updating problem. These are the poles */
/* > of the secular equation. */
/* > \endverbatim */
/* > */
/* > \param[in] W */
/* > \verbatim */
/* > W is DOUBLE PRECISION array, dimension (K) */
/* > The first K elements of this array contain the components */
/* > of the deflation-adjusted updating vector. */
/* > \endverbatim */
/* > */
/* > \param[out] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION array, dimension (LDS, K) */
/* > Will contain the eigenvectors of the repaired matrix which */
/* > will be stored for subsequent Z vector calculation and */
/* > multiplied by the previously accumulated eigenvectors */
/* > to update the system. */
/* > \endverbatim */
/* > */
/* > \param[in] LDS */
/* > \verbatim */
/* > LDS is INTEGER */
/* > The leading dimension of S. LDS >= max( 1, K ). */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: if INFO = 1, an eigenvalue did not converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* ===================================================================== */
/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop,
integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal *
rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds,
integer *info)
int dlaed9_(integer *k, integer *kstart, integer *kstop, integer *n, doublereal *d__, doublereal *q,
integer *ldq, doublereal *rho, doublereal *dlamda, doublereal *w, doublereal *s,
integer *lds, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j;
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlaed4_(integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dlaed4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen);
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
@ -233,21 +27,18 @@ f"> */
s_dim1 = *lds;
s_offset = 1 + s_dim1;
s -= s_offset;
/* Function Body */
*info = 0;
if (*k < 0) {
*info = -1;
} else if (*kstart < 1 || *kstart > max(1,*k)) {
} else if (*kstart < 1 || *kstart > max(1, *k)) {
*info = -2;
} else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) {
} else if (max(1, *kstop) < *kstart || *kstop > max(1, *k)) {
*info = -3;
} else if (*n < *k) {
*info = -4;
} else if (*ldq < max(1,*k)) {
} else if (*ldq < max(1, *k)) {
*info = -7;
} else if (*lds < max(1,*k)) {
} else if (*lds < max(1, *k)) {
*info = -12;
}
if (*info != 0) {
@ -255,68 +46,31 @@ f"> */
xerbla_((char *)"DLAED9", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*k == 0) {
return 0;
}
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DLAMDA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */
}
i__1 = *kstop;
for (j = *kstart; j <= i__1; ++j) {
dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
info);
/* If the zero finder fails, the computation is terminated. */
dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], info);
if (*info != 0) {
goto L120;
}
/* L20: */
}
if (*k == 1 || *k == 2) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *k;
for (j = 1; j <= i__2; ++j) {
s[j + i__ * s_dim1] = q[j + i__ * q_dim1];
/* L30: */
}
/* L40: */
}
goto L120;
}
/* Compute updated W. */
dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1);
/* Initialize W(I) = Q(I,I) */
i__1 = *ldq + 1;
dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
i__1 = *k;
@ -324,47 +78,32 @@ f"> */
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L50: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L60: */
}
/* L70: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = sqrt(-w[i__]);
w[i__] = d_lmp_sign(&d__1, &s[i__ + s_dim1]);
/* L80: */
}
/* Compute eigenvectors of the modified rank-1 modification. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1];
/* L90: */
}
temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1);
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp;
/* L100: */
}
/* L110: */
}
L120:
return 0;
/* End of DLAED9 */
} /* dlaed9_ */
}
#ifdef __cplusplus
}
}
#endif

331
lib/linalg/dlaeda.cpp
View File

@ -1,242 +1,26 @@
/* fortran/dlaeda.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
static doublereal c_b24 = 1.;
static doublereal c_b26 = 0.;
/* > \brief \b DLAEDA used by DSTEDC. Computes the Z vector determining the rank-one modification of the diago
nal matrix. Used when the original matrix is dense. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAEDA + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaeda.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaeda.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaeda.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, */
/* GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER CURLVL, CURPBM, INFO, N, TLVLS */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), */
/* $ PRMPTR( * ), QPTR( * ) */
/* DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAEDA computes the Z vector corresponding to the merge step in the */
/* > CURLVLth step of the merge process with TLVLS steps for the CURPBMth */
/* > problem. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] TLVLS */
/* > \verbatim */
/* > TLVLS is INTEGER */
/* > The total number of merging levels in the overall divide and */
/* > conquer tree. */
/* > \endverbatim */
/* > */
/* > \param[in] CURLVL */
/* > \verbatim */
/* > CURLVL is INTEGER */
/* > The current level in the overall merge routine, */
/* > 0 <= curlvl <= tlvls. */
/* > \endverbatim */
/* > */
/* > \param[in] CURPBM */
/* > \verbatim */
/* > CURPBM is INTEGER */
/* > The current problem in the current level in the overall */
/* > merge routine (counting from upper left to lower right). */
/* > \endverbatim */
/* > */
/* > \param[in] PRMPTR */
/* > \verbatim */
/* > PRMPTR is INTEGER array, dimension (N lg N) */
/* > Contains a list of pointers which indicate where in PERM a */
/* > level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
/* > indicates the size of the permutation and incidentally the */
/* > size of the full, non-deflated problem. */
/* > \endverbatim */
/* > */
/* > \param[in] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, dimension (N lg N) */
/* > Contains the permutations (from deflation and sorting) to be */
/* > applied to each eigenblock. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER array, dimension (N lg N) */
/* > Contains a list of pointers which indicate where in GIVCOL a */
/* > level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
/* > indicates the number of Givens rotations. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, dimension (2, N lg N) */
/* > Each pair of numbers indicates a pair of columns to take place */
/* > in a Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) */
/* > Each number indicates the S value to be used in the */
/* > corresponding Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[in] Q */
/* > \verbatim */
/* > Q is DOUBLE PRECISION array, dimension (N**2) */
/* > Contains the square eigenblocks from previous levels, the */
/* > starting positions for blocks are given by QPTR. */
/* > \endverbatim */
/* > */
/* > \param[in] QPTR */
/* > \verbatim */
/* > QPTR is INTEGER array, dimension (N+2) */
/* > Contains a list of pointers which indicate where in Q an */
/* > eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates */
/* > the size of the block. */
/* > \endverbatim */
/* > */
/* > \param[out] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension (N) */
/* > On output this vector contains the updating vector (the last */
/* > row of the first sub-eigenvector matrix and the first row of */
/* > the second sub-eigenvector matrix). */
/* > \endverbatim */
/* > */
/* > \param[out] ZTEMP */
/* > \verbatim */
/* > ZTEMP is DOUBLE PRECISION array, dimension (N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Jeff Rutter, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* ===================================================================== */
/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl,
integer *curpbm, integer *prmptr, integer *perm, integer *givptr,
integer *givcol, doublereal *givnum, doublereal *q, integer *qptr,
doublereal *z__, doublereal *ztemp, integer *info)
int dlaeda_(integer *n, integer *tlvls, integer *curlvl, integer *curpbm, integer *prmptr,
integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublereal *q,
integer *qptr, doublereal *z__, doublereal *ztemp, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer pow_lmp_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
integer i__, k, mid, ptr;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), xerbla_(char *,
integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *, ftnlen);
--ztemp;
--z__;
--qptr;
@ -246,10 +30,7 @@ f"> */
--givptr;
--perm;
--prmptr;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
}
@ -258,129 +39,75 @@ f"> */
xerbla_((char *)"DLAEDA", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine location of first number in second half. */
mid = *n / 2 + 1;
/* Gather last/first rows of appropriate eigenblocks into center of Z */
ptr = 1;
/* Determine location of lowest level subproblem in the full storage */
/* scheme */
i__1 = *curlvl - 1;
curr = ptr + *curpbm * pow_lmp_ii(&c__2, curlvl) + pow_lmp_ii(&c__2, &i__1) - 1;
/* Determine size of these matrices. We add HALF to the value of */
/* the SQRT in case the machine underestimates one of these square */
/* roots. */
bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + .5);
bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) +
.5);
bsiz1 = (integer)(sqrt((doublereal)(qptr[curr + 1] - qptr[curr])) + .5);
bsiz2 = (integer)(sqrt((doublereal)(qptr[curr + 2] - qptr[curr + 1])) + .5);
i__1 = mid - bsiz1 - 1;
for (k = 1; k <= i__1; ++k) {
z__[k] = 0.;
/* L10: */
}
dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &
c__1);
dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &c__1);
dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1);
i__1 = *n;
for (k = mid + bsiz2; k <= i__1; ++k) {
z__[k] = 0.;
/* L20: */
}
/* Loop through remaining levels 1 -> CURLVL applying the Givens */
/* rotations and permutation and then multiplying the center matrices */
/* against the current Z. */
ptr = pow_lmp_ii(&c__2, tlvls) + 1;
i__1 = *curlvl - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = *curlvl - k;
i__3 = *curlvl - k - 1;
curr = ptr + *curpbm * pow_lmp_ii(&c__2, &i__2) + pow_lmp_ii(&c__2, &i__3) -
1;
curr = ptr + *curpbm * pow_lmp_ii(&c__2, &i__2) + pow_lmp_ii(&c__2, &i__3) - 1;
psiz1 = prmptr[curr + 1] - prmptr[curr];
psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
zptr1 = mid - psiz1;
/* Apply Givens at CURR and CURR+1 */
i__2 = givptr[curr + 1] - 1;
for (i__ = givptr[curr]; i__ <= i__2; ++i__) {
drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, &
z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[(
i__ << 1) + 1], &givnum[(i__ << 1) + 2]);
/* L30: */
drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1,
&z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[(i__ << 1) + 1],
&givnum[(i__ << 1) + 2]);
}
i__2 = givptr[curr + 2] - 1;
for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) {
drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[
mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ <<
1) + 1], &givnum[(i__ << 1) + 2]);
/* L40: */
drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1,
&z__[mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << 1) + 1],
&givnum[(i__ << 1) + 2]);
}
psiz1 = prmptr[curr + 1] - prmptr[curr];
psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
i__2 = psiz1 - 1;
for (i__ = 0; i__ <= i__2; ++i__) {
ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1];
/* L50: */
}
i__2 = psiz2 - 1;
for (i__ = 0; i__ <= i__2; ++i__) {
ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] -
1];
/* L60: */
ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - 1];
}
/* Multiply Blocks at CURR and CURR+1 */
/* Determine size of these matrices. We add HALF to the value of */
/* the SQRT in case the machine underestimates one of these */
/* square roots. */
bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) +
.5);
bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])
) + .5);
bsiz1 = (integer)(sqrt((doublereal)(qptr[curr + 1] - qptr[curr])) + .5);
bsiz2 = (integer)(sqrt((doublereal)(qptr[curr + 2] - qptr[curr + 1])) + .5);
if (bsiz1 > 0) {
dgemv_((char *)"T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &
ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1, (ftnlen)1);
dgemv_((char *)"T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &ztemp[1], &c__1, &c_b26,
&z__[zptr1], &c__1, (ftnlen)1);
}
i__2 = psiz1 - bsiz1;
dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1);
if (bsiz2 > 0) {
dgemv_((char *)"T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &
ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1, (
ftnlen)1);
dgemv_((char *)"T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &ztemp[psiz1 + 1],
&c__1, &c_b26, &z__[mid], &c__1, (ftnlen)1);
}
i__2 = psiz2 - bsiz2;
dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &
c__1);
dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &c__1);
i__2 = *tlvls - k;
ptr += pow_lmp_ii(&c__2, &i__2);
/* L70: */
}
return 0;
/* End of DLAEDA */
} /* dlaeda_ */
}
#ifdef __cplusplus
}
}
#endif

193
lib/linalg/dlaev2.cpp
View File

@ -1,175 +1,15 @@
/* fortran/dlaev2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAEV2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaev2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaev2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaev2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */
/* > [ A B ] */
/* > [ B C ]. */
/* > On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
/* > eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
/* > eigenvector for RT1, giving the decomposition */
/* > */
/* > [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] */
/* > [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION */
/* > The (1,1) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION */
/* > The (1,2) element and the conjugate of the (2,1) element of */
/* > the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION */
/* > The (2,2) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] RT1 */
/* > \verbatim */
/* > RT1 is DOUBLE PRECISION */
/* > The eigenvalue of larger absolute value. */
/* > \endverbatim */
/* > */
/* > \param[out] RT2 */
/* > \verbatim */
/* > RT2 is DOUBLE PRECISION */
/* > The eigenvalue of smaller absolute value. */
/* > \endverbatim */
/* > */
/* > \param[out] CS1 */
/* > \verbatim */
/* > CS1 is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[out] SN1 */
/* > \verbatim */
/* > SN1 is DOUBLE PRECISION */
/* > The vector (CS1, SN1) is a unit right eigenvector for RT1. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > RT1 is accurate to a few ulps barring over/underflow. */
/* > */
/* > RT2 may be inaccurate if there is massive cancellation in the */
/* > determinant A*C-B*B; higher precision or correctly rounded or */
/* > correctly truncated arithmetic would be needed to compute RT2 */
/* > accurately in all cases. */
/* > */
/* > CS1 and SN1 are accurate to a few ulps barring over/underflow. */
/* > */
/* > Overflow is possible only if RT1 is within a factor of 5 of overflow. */
/* > Underflow is harmless if the input data is 0 or exceeds */
/* > underflow_threshold / macheps. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1)
int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, doublereal *rt1, doublereal *rt2,
doublereal *cs1, doublereal *sn1)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
integer sgn1, sgn2;
doublereal acmn, acmx;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Compute the eigenvalues */
sm = *a + *c__;
df = *a - *c__;
adf = abs(df);
@ -183,48 +23,27 @@ f"> */
acmn = *a;
}
if (adf > ab) {
/* Computing 2nd power */
d__1 = ab / adf;
rt = adf * sqrt(d__1 * d__1 + 1.);
} else if (adf < ab) {
/* Computing 2nd power */
d__1 = adf / ab;
rt = ab * sqrt(d__1 * d__1 + 1.);
} else {
/* Includes case AB=ADF=0 */
rt = ab * sqrt(2.);
}
if (sm < 0.) {
*rt1 = (sm - rt) * .5;
sgn1 = -1;
/* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else if (sm > 0.) {
*rt1 = (sm + rt) * .5;
sgn1 = 1;
/* Order of execution important. */
/* To get fully accurate smaller eigenvalue, */
/* next line needs to be executed in higher precision. */
*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
} else {
/* Includes case RT1 = RT2 = 0 */
*rt1 = rt * .5;
*rt2 = rt * -.5;
sgn1 = 1;
}
/* Compute the eigenvector */
if (df >= 0.) {
cs = df + rt;
sgn2 = 1;
@ -253,11 +72,7 @@ f"> */
*sn1 = tn;
}
return 0;
/* End of DLAEV2 */
} /* dlaev2_ */
}
#ifdef __cplusplus
}
}
#endif

493
lib/linalg/dlals0.cpp
View File

@ -1,359 +1,40 @@
/* fortran/dlals0.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b5 = -1.;
static integer c__1 = 1;
static doublereal c_b11 = 1.;
static doublereal c_b13 = 0.;
static integer c__0 = 0;
/* > \brief \b DLALS0 applies back multiplying factors in solving the least squares problem using divide and c
onquer SVD approach. Used by sgelsd. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLALS0 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlals0.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlals0.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlals0.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, */
/* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, */
/* POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, */
/* $ LDGNUM, NL, NR, NRHS, SQRE */
/* DOUBLE PRECISION C, S */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( LDGCOL, * ), PERM( * ) */
/* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), */
/* $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), */
/* $ POLES( LDGNUM, * ), WORK( * ), Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLALS0 applies back the multiplying factors of either the left or the */
/* > right singular vector matrix of a diagonal matrix appended by a row */
/* > to the right hand side matrix B in solving the least squares problem */
/* > using the divide-and-conquer SVD approach. */
/* > */
/* > For the left singular vector matrix, three types of orthogonal */
/* > matrices are involved: */
/* > */
/* > (1L) Givens rotations: the number of such rotations is GIVPTR; the */
/* > pairs of columns/rows they were applied to are stored in GIVCOL; */
/* > and the C- and S-values of these rotations are stored in GIVNUM. */
/* > */
/* > (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */
/* > row, and for J=2:N, PERM(J)-th row of B is to be moved to the */
/* > J-th row. */
/* > */
/* > (3L) The left singular vector matrix of the remaining matrix. */
/* > */
/* > For the right singular vector matrix, four types of orthogonal */
/* > matrices are involved: */
/* > */
/* > (1R) The right singular vector matrix of the remaining matrix. */
/* > */
/* > (2R) If SQRE = 1, one extra Givens rotation to generate the right */
/* > null space. */
/* > */
/* > (3R) The inverse transformation of (2L). */
/* > */
/* > (4R) The inverse transformation of (1L). */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > Specifies whether singular vectors are to be computed in */
/* > factored form: */
/* > = 0: Left singular vector matrix. */
/* > = 1: Right singular vector matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] NL */
/* > \verbatim */
/* > NL is INTEGER */
/* > The row dimension of the upper block. NL >= 1. */
/* > \endverbatim */
/* > */
/* > \param[in] NR */
/* > \verbatim */
/* > NR is INTEGER */
/* > The row dimension of the lower block. NR >= 1. */
/* > \endverbatim */
/* > */
/* > \param[in] SQRE */
/* > \verbatim */
/* > SQRE is INTEGER */
/* > = 0: the lower block is an NR-by-NR square matrix. */
/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
/* > */
/* > The bidiagonal matrix has row dimension N = NL + NR + 1, */
/* > and column dimension M = N + SQRE. */
/* > \endverbatim */
/* > */
/* > \param[in] NRHS */
/* > \verbatim */
/* > NRHS is INTEGER */
/* > The number of columns of B and BX. NRHS must be at least 1. */
/* > \endverbatim */
/* > */
/* > \param[in,out] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) */
/* > On input, B contains the right hand sides of the least */
/* > squares problem in rows 1 through M. On output, B contains */
/* > the solution X in rows 1 through N. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > The leading dimension of B. LDB must be at least */
/* > max(1,MAX( M, N ) ). */
/* > \endverbatim */
/* > */
/* > \param[out] BX */
/* > \verbatim */
/* > BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */
/* > \endverbatim */
/* > */
/* > \param[in] LDBX */
/* > \verbatim */
/* > LDBX is INTEGER */
/* > The leading dimension of BX. */
/* > \endverbatim */
/* > */
/* > \param[in] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, dimension ( N ) */
/* > The permutations (from deflation and sorting) applied */
/* > to the two blocks. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER */
/* > The number of Givens rotations which took place in this */
/* > subproblem. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) */
/* > Each pair of numbers indicates a pair of rows/columns */
/* > involved in a Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGCOL */
/* > \verbatim */
/* > LDGCOL is INTEGER */
/* > The leading dimension of GIVCOL, must be at least N. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* > Each number indicates the C or S value used in the */
/* > corresponding Givens rotation. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGNUM */
/* > \verbatim */
/* > LDGNUM is INTEGER */
/* > The leading dimension of arrays DIFR, POLES and */
/* > GIVNUM, must be at least K. */
/* > \endverbatim */
/* > */
/* > \param[in] POLES */
/* > \verbatim */
/* > POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* > On entry, POLES(1:K, 1) contains the new singular */
/* > values obtained from solving the secular equation, and */
/* > POLES(1:K, 2) is an array containing the poles in the secular */
/* > equation. */
/* > \endverbatim */
/* > */
/* > \param[in] DIFL */
/* > \verbatim */
/* > DIFL is DOUBLE PRECISION array, dimension ( K ). */
/* > On entry, DIFL(I) is the distance between I-th updated */
/* > (undeflated) singular value and the I-th (undeflated) old */
/* > singular value. */
/* > \endverbatim */
/* > */
/* > \param[in] DIFR */
/* > \verbatim */
/* > DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). */
/* > On entry, DIFR(I, 1) contains the distances between I-th */
/* > updated (undeflated) singular value and the I+1-th */
/* > (undeflated) old singular value. And DIFR(I, 2) is the */
/* > normalizing factor for the I-th right singular vector. */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( K ) */
/* > Contain the components of the deflation-adjusted updating row */
/* > vector. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > Contains the dimension of the non-deflated matrix, */
/* > This is the order of the related secular equation. 1 <= K <=N. */
/* > \endverbatim */
/* > */
/* > \param[in] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION */
/* > C contains garbage if SQRE =0 and the C-value of a Givens */
/* > rotation related to the right null space if SQRE = 1. */
/* > \endverbatim */
/* > */
/* > \param[in] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION */
/* > S contains garbage if SQRE =0 and the S-value of a Givens */
/* > rotation related to the right null space if SQRE = 1. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension ( K ) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* > California at Berkeley, USA \n */
/* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */
/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal
*bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol,
integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *
poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *
k, doublereal *c__, doublereal *s, doublereal *work, integer *info)
int dlals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, doublereal *b,
integer *ldb, doublereal *bx, integer *ldbx, integer *perm, integer *givptr,
integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum,
doublereal *poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *k,
doublereal *c__, doublereal *s, doublereal *work, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset,
difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1,
poles_offset, i__1, i__2;
integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, difr_dim1,
difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, j, m, n;
doublereal dj;
integer nlp1;
doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *);
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlacpy_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, ftnlen),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
doublereal dsigjp;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
@ -376,11 +57,8 @@ f"> */
--difl;
--z__;
--work;
/* Function Body */
*info = 0;
n = *nl + *nr + 1;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*nl < 1) {
@ -409,37 +87,20 @@ f"> */
xerbla_((char *)"DLALS0", &i__1, (ftnlen)6);
return 0;
}
m = n + *sqre;
nlp1 = *nl + 1;
if (*icompq == 0) {
/* Apply back orthogonal transformations from the left. */
/* Step (1L): apply back the Givens rotations performed. */
i__1 = *givptr;
for (i__ = 1; i__ <= i__1; ++i__) {
drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
(givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
/* L10: */
drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb,
&b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + (givnum_dim1 << 1)],
&givnum[i__ + givnum_dim1]);
}
/* Step (2L): permute rows of B. */
dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1],
ldbx);
/* L20: */
dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], ldbx);
}
/* Step (3L): apply the inverse of the left singular vector */
/* matrix to BX. */
if (*k == 1) {
dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
if (z__[1] < 0.) {
@ -459,58 +120,42 @@ f"> */
work[j] = 0.;
} else {
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;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
0.) {
if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == 0.) {
work[i__] = 0.;
} else {
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
/ (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
dsigj) - diflj) / (poles[i__ + (poles_dim1 <<
1)] + dj);
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] /
(dlamc3_(&poles[i__ + (poles_dim1 << 1)], &dsigj) - diflj) /
(poles[i__ + (poles_dim1 << 1)] + dj);
}
/* L30: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
0.) {
if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == 0.) {
work[i__] = 0.;
} else {
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
/ (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
1)] + dj);
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] /
(dlamc3_(&poles[i__ + (poles_dim1 << 1)], &dsigjp) + difrj) /
(poles[i__ + (poles_dim1 << 1)] + dj);
}
/* L40: */
}
work[1] = -1.;
temp = dnrm2_(k, &work[1], &c__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);
dlascl_((char *)"G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j +
b_dim1], ldb, info, (ftnlen)1);
/* L50: */
dgemv_((char *)"T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[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 + b_dim1], ldb, info,
(ftnlen)1);
}
}
/* Move the deflated rows of BX to B also. */
if (*k < max(m,n)) {
if (*k < max(m, n)) {
i__1 = n - *k;
dlacpy_((char *)"A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1
+ b_dim1], ldb, (ftnlen)1);
dlacpy_((char *)"A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 + b_dim1], ldb,
(ftnlen)1);
}
} else {
/* Apply back the right orthogonal transformations. */
/* Step (1R): apply back the new right singular vector matrix */
/* to B. */
if (*k == 1) {
dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
} else {
@ -520,8 +165,8 @@ f"> */
if (z__[j] == 0.) {
work[j] = 0.;
} else {
work[j] = -z__[j] / difl[j] / (dsigj + poles[j +
poles_dim1]) / difr[j + (difr_dim1 << 1)];
work[j] = -z__[j] / difl[j] / (dsigj + poles[j + poles_dim1]) /
difr[j + (difr_dim1 << 1)];
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
@ -529,11 +174,10 @@ f"> */
work[i__] = 0.;
} else {
d__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[
i__ + difr_dim1]) / (dsigj + poles[i__ +
poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[i__ + difr_dim1]) /
(dsigj + poles[i__ + poles_dim1]) /
difr[i__ + (difr_dim1 << 1)];
}
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
@ -541,62 +185,41 @@ f"> */
work[i__] = 0.;
} else {
d__1 = -poles[i__ + (poles_dim1 << 1)];
work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[
i__]) / (dsigj + poles[i__ + poles_dim1]) /
difr[i__ + (difr_dim1 << 1)];
work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[i__]) /
(dsigj + poles[i__ + poles_dim1]) /
difr[i__ + (difr_dim1 << 1)];
}
/* L70: */
}
dgemv_((char *)"T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
c__1, &c_b13, &bx[j + bx_dim1], ldbx, (ftnlen)1);
/* L80: */
dgemv_((char *)"T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &c__1, &c_b13,
&bx[j + bx_dim1], ldbx, (ftnlen)1);
}
}
/* Step (2R): if SQRE = 1, apply back the rotation that is */
/* related to the right null space of the subproblem. */
if (*sqre == 1) {
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__,
s);
drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, s);
}
if (*k < max(m,n)) {
if (*k < max(m, n)) {
i__1 = n - *k;
dlacpy_((char *)"A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 +
bx_dim1], ldbx, (ftnlen)1);
dlacpy_((char *)"A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + bx_dim1], ldbx,
(ftnlen)1);
}
/* Step (3R): permute rows of B. */
dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
if (*sqre == 1) {
dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
}
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1],
ldb);
/* L90: */
dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], ldb);
}
/* Step (4R): apply back the Givens rotations performed. */
for (i__ = *givptr; i__ >= 1; --i__) {
d__1 = -givnum[i__ + givnum_dim1];
drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
(givnum_dim1 << 1)], &d__1);
/* L100: */
drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb,
&b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + (givnum_dim1 << 1)],
&d__1);
}
}
return 0;
/* End of DLALS0 */
} /* dlals0_ */
}
#ifdef __cplusplus
}
}
#endif

475
lib/linalg/dlalsa.cpp
View File

@ -1,349 +1,35 @@
/* fortran/dlalsa.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b7 = 1.;
static doublereal c_b8 = 0.;
static integer c__2 = 2;
/* > \brief \b DLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLALSA + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlalsa.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlalsa.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlalsa.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, */
/* LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, */
/* GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, */
/* IWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, */
/* $ SMLSIZ */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), */
/* $ K( * ), PERM( LDGCOL, * ) */
/* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), */
/* $ DIFL( LDU, * ), DIFR( LDU, * ), */
/* $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), */
/* $ U( LDU, * ), VT( LDU, * ), WORK( * ), */
/* $ Z( LDU, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLALSA is an itermediate step in solving the least squares problem */
/* > by computing the SVD of the coefficient matrix in compact form (The */
/* > singular vectors are computed as products of simple orthorgonal */
/* > matrices.). */
/* > */
/* > If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector */
/* > matrix of an upper bidiagonal matrix to the right hand side; and if */
/* > ICOMPQ = 1, DLALSA applies the right singular vector matrix to the */
/* > right hand side. The singular vector matrices were generated in */
/* > compact form by DLALSA. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > Specifies whether the left or the right singular vector */
/* > matrix is involved. */
/* > = 0: Left singular vector matrix */
/* > = 1: Right singular vector matrix */
/* > \endverbatim */
/* > */
/* > \param[in] SMLSIZ */
/* > \verbatim */
/* > SMLSIZ is INTEGER */
/* > The maximum size of the subproblems at the bottom of the */
/* > computation tree. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The row and column dimensions of the upper bidiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] NRHS */
/* > \verbatim */
/* > NRHS is INTEGER */
/* > The number of columns of B and BX. NRHS must be at least 1. */
/* > \endverbatim */
/* > */
/* > \param[in,out] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) */
/* > On input, B contains the right hand sides of the least */
/* > squares problem in rows 1 through M. */
/* > On output, B contains the solution X in rows 1 through N. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > The leading dimension of B in the calling subprogram. */
/* > LDB must be at least max(1,MAX( M, N ) ). */
/* > \endverbatim */
/* > */
/* > \param[out] BX */
/* > \verbatim */
/* > BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */
/* > On exit, the result of applying the left or right singular */
/* > vector matrix to B. */
/* > \endverbatim */
/* > */
/* > \param[in] LDBX */
/* > \verbatim */
/* > LDBX is INTEGER */
/* > The leading dimension of BX. */
/* > \endverbatim */
/* > */
/* > \param[in] U */
/* > \verbatim */
/* > U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). */
/* > On entry, U contains the left singular vector matrices of all */
/* > subproblems at the bottom level. */
/* > \endverbatim */
/* > */
/* > \param[in] LDU */
/* > \verbatim */
/* > LDU is INTEGER, LDU = > N. */
/* > The leading dimension of arrays U, VT, DIFL, DIFR, */
/* > POLES, GIVNUM, and Z. */
/* > \endverbatim */
/* > */
/* > \param[in] VT */
/* > \verbatim */
/* > VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). */
/* > On entry, VT**T contains the right singular vector matrices of */
/* > all subproblems at the bottom level. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER array, dimension ( N ). */
/* > \endverbatim */
/* > */
/* > \param[in] DIFL */
/* > \verbatim */
/* > DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
/* > where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */
/* > \endverbatim */
/* > */
/* > \param[in] DIFR */
/* > \verbatim */
/* > DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
/* > On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */
/* > distances between singular values on the I-th level and */
/* > singular values on the (I -1)-th level, and DIFR(*, 2 * I) */
/* > record the normalizing factors of the right singular vectors */
/* > matrices of subproblems on I-th level. */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
/* > On entry, Z(1, I) contains the components of the deflation- */
/* > adjusted updating row vector for subproblems on the I-th */
/* > level. */
/* > \endverbatim */
/* > */
/* > \param[in] POLES */
/* > \verbatim */
/* > POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
/* > On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */
/* > singular values involved in the secular equations on the I-th */
/* > level. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER array, dimension ( N ). */
/* > On entry, GIVPTR( I ) records the number of Givens */
/* > rotations performed on the I-th problem on the computation */
/* > tree. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */
/* > On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */
/* > locations of Givens rotations performed on the I-th level on */
/* > the computation tree. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGCOL */
/* > \verbatim */
/* > LDGCOL is INTEGER, LDGCOL = > N. */
/* > The leading dimension of arrays GIVCOL and PERM. */
/* > \endverbatim */
/* > */
/* > \param[in] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, dimension ( LDGCOL, NLVL ). */
/* > On entry, PERM(*, I) records permutations done on the I-th */
/* > level of the computation tree. */
/* > \endverbatim */
/* > */
/* > \param[in] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
/* > On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */
/* > values of Givens rotations performed on the I-th level on the */
/* > computation tree. */
/* > \endverbatim */
/* > */
/* > \param[in] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension ( N ). */
/* > On entry, if the I-th subproblem is not square, */
/* > C( I ) contains the C-value of a Givens rotation related to */
/* > the right null space of the I-th subproblem. */
/* > \endverbatim */
/* > */
/* > \param[in] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION array, dimension ( N ). */
/* > On entry, if the I-th subproblem is not square, */
/* > S( I ) contains the S-value of a Givens rotation related to */
/* > the right null space of the I-th subproblem. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (N) */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension (3*N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* > California at Berkeley, USA \n */
/* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */
/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n,
integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *
ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k,
doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
work, integer *iwork, integer *info)
int dlalsa_(integer *icompq, integer *smlsiz, integer *n, integer *nrhs, doublereal *b,
integer *ldb, doublereal *bx, integer *ldbx, doublereal *u, integer *ldu,
doublereal *vt, integer *k, doublereal *difl, doublereal *difr, doublereal *z__,
doublereal *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm,
doublereal *givnum, doublereal *c__, doublereal *s, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1,
b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1,
difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset,
u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1,
i__2;
/* Builtin functions */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, b_offset, bx_dim1,
bx_offset, difl_dim1, difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1,
i__2;
integer pow_lmp_ii(integer *, integer *);
/* Local variables */
integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1,
nlp1, lvl2, nrp1, nlvl, sqre;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen);
integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, nlp1, lvl2, nrp1, nlvl,
sqre;
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer inode, ndiml, ndimr;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlals0_(integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dlasdt_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dlals0_(integer *, integer *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dlasdt_(integer *, integer *, integer *, integer *, integer *, integer *, integer *),
xerbla_(char *, integer *, ftnlen);
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
@ -383,10 +69,7 @@ f"> */
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*smlsiz < 3) {
@ -409,75 +92,36 @@ f"> */
xerbla_((char *)"DLALSA", &i__1, (ftnlen)6);
return 0;
}
/* Book-keeping and setting up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* The following code applies back the left singular vector factors. */
/* For applying back the right singular vector factors, go to 50. */
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], smlsiz);
if (*icompq == 1) {
goto L50;
}
/* The nodes on the bottom level of the tree were solved */
/* by DLASDQ. The corresponding left and right singular vector */
/* matrices are in explicit form. First apply back the left */
/* singular vector matrices. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node */
/* NL : number of rows of left subproblem */
/* NR : number of rows of right subproblem */
/* NLF: starting row of the left subproblem */
/* NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nr = iwork[ndimr + i1];
nlf = ic - nl;
nrf = ic + 1;
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, (
ftnlen)1);
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, (
ftnlen)1);
/* L10: */
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, (ftnlen)1);
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, (ftnlen)1);
}
/* Next copy the rows of B that correspond to unchanged rows */
/* in the bidiagonal matrix to BX. */
i__1 = nd;
for (i__ = 1; i__ <= i__1; ++i__) {
ic = iwork[inode + i__ - 1];
dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx);
/* L20: */
}
/* Finally go through the left singular vector matrices of all */
/* the other subproblems bottom-up on the tree. */
j = pow_lmp_ii(&c__2, &nlvl);
sqre = 0;
for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1;
/* find the first node LF and last node LL on */
/* the current level LVL */
if (lvl == 1) {
lf = 1;
ll = 1;
@ -495,34 +139,19 @@ f"> */
nlf = ic - nl;
nrf = ic + 1;
--j;
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &
b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], &
givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
j], &s[j], &work[1], info);
/* L30: */
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &b[nlf + b_dim1], ldb,
&perm[nlf + lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * givcol_dim1],
ldgcol, &givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1],
&difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * difr_dim1],
&z__[nlf + lvl * z_dim1], &k[j], &c__[j], &s[j], &work[1], info);
}
/* L40: */
}
goto L90;
/* ICOMPQ = 1: applying back the right singular vector factors. */
L50:
/* First now go through the right singular vector matrices of all */
/* the tree nodes top-down. */
j = 0;
i__1 = nlvl;
for (lvl = 1; lvl <= i__1; ++lvl) {
lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on */
/* the current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
@ -545,22 +174,13 @@ L50:
sqre = 1;
}
++j;
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[
nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], &
givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
j], &s[j], &work[1], info);
/* L60: */
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[nlf + bx_dim1], ldbx,
&perm[nlf + lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * givcol_dim1],
ldgcol, &givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1],
&difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * difr_dim1],
&z__[nlf + lvl * z_dim1], &k[j], &c__[j], &s[j], &work[1], info);
}
/* L70: */
}
/* The nodes on the bottom level of the tree were solved */
/* by DLASDQ. The corresponding right singular vector */
/* matrices are in explicit form. Apply them back. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
@ -576,23 +196,14 @@ L50:
}
nlf = ic - nl;
nrf = ic + 1;
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, (
ftnlen)1, (ftnlen)1);
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, (
ftnlen)1, (ftnlen)1);
/* L80: */
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, (ftnlen)1, (ftnlen)1);
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, (ftnlen)1, (ftnlen)1);
}
L90:
return 0;
/* End of DLALSA */
} /* dlalsa_ */
}
#ifdef __cplusplus
}
}
#endif

498
lib/linalg/dlalsd.cpp
View File

@ -1,219 +1,18 @@
/* fortran/dlalsd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b6 = 0.;
static integer c__0 = 0;
static doublereal c_b11 = 1.;
/* > \brief \b DLALSD uses the singular value decomposition of A to solve the least squares problem. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLALSD + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlalsd.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlalsd.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlalsd.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, */
/* RANK, WORK, IWORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER UPLO */
/* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ */
/* DOUBLE PRECISION RCOND */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IWORK( * ) */
/* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLALSD uses the singular value decomposition of A to solve the least */
/* > squares problem of finding X to minimize the Euclidean norm of each */
/* > column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
/* > are N-by-NRHS. The solution X overwrites B. */
/* > */
/* > The singular values of A smaller than RCOND times the largest */
/* > singular value are treated as zero in solving the least squares */
/* > problem; in this case a minimum norm solution is returned. */
/* > The actual singular values are returned in D in ascending order. */
/* > */
/* > This code makes very mild assumptions about floating point */
/* > arithmetic. It will work on machines with a guard digit in */
/* > add/subtract, or on those binary machines without guard digits */
/* > which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
/* > It could conceivably fail on hexadecimal or decimal machines */
/* > without guard digits, but we know of none. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] UPLO */
/* > \verbatim */
/* > UPLO is CHARACTER*1 */
/* > = 'U': D and E define an upper bidiagonal matrix. */
/* > = 'L': D and E define a lower bidiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] SMLSIZ */
/* > \verbatim */
/* > SMLSIZ is INTEGER */
/* > The maximum size of the subproblems at the bottom of the */
/* > computation tree. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The dimension of the bidiagonal matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] NRHS */
/* > \verbatim */
/* > NRHS is INTEGER */
/* > The number of columns of B. NRHS must be at least 1. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry D contains the main diagonal of the bidiagonal */
/* > matrix. On exit, if INFO = 0, D contains its singular values. */
/* > \endverbatim */
/* > */
/* > \param[in,out] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (N-1) */
/* > Contains the super-diagonal entries of the bidiagonal matrix. */
/* > On exit, E has been destroyed. */
/* > \endverbatim */
/* > */
/* > \param[in,out] B */
/* > \verbatim */
/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* > On input, B contains the right hand sides of the least */
/* > squares problem. On output, B contains the solution X. */
/* > \endverbatim */
/* > */
/* > \param[in] LDB */
/* > \verbatim */
/* > LDB is INTEGER */
/* > The leading dimension of B in the calling subprogram. */
/* > LDB must be at least max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] RCOND */
/* > \verbatim */
/* > RCOND is DOUBLE PRECISION */
/* > The singular values of A less than or equal to RCOND times */
/* > the largest singular value are treated as zero in solving */
/* > the least squares problem. If RCOND is negative, */
/* > machine precision is used instead. */
/* > For example, if diag(S)*X=B were the least squares problem, */
/* > where diag(S) is a diagonal matrix of singular values, the */
/* > solution would be X(i) = B(i) / S(i) if S(i) is greater than */
/* > RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
/* > RCOND*max(S). */
/* > \endverbatim */
/* > */
/* > \param[out] RANK */
/* > \verbatim */
/* > RANK is INTEGER */
/* > The number of singular values of A greater than RCOND times */
/* > the largest singular value. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension at least */
/* > (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */
/* > where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension at least */
/* > (3*N*NLVL + 11*N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: The algorithm failed to compute a singular value while */
/* > working on the submatrix lying in rows and columns */
/* > INFO/(N+1) through MOD(INFO,N+1). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* > California at Berkeley, USA \n */
/* > Osni Marques, LBNL/NERSC, USA \n */
/* ===================================================================== */
/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
integer *info, ftnlen uplo_len)
int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, doublereal *d__, doublereal *e,
doublereal *b, integer *ldb, doublereal *rcond, integer *rank, doublereal *work,
integer *iwork, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal), d_lmp_sign(doublereal *, doublereal *);
/* Local variables */
integer c__, i__, j, k;
doublereal r__;
integer s, u, z__;
@ -227,74 +26,42 @@ f"> */
integer difl, difr;
doublereal rcnd;
integer perm, nsub;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer nlvl, sqre, bxst;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer
*);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dlalsa_(integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
extern int dlasda_(integer *, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *),
dlalsa_(integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, ftnlen), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen), dlartg_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern int dlasdq_(char *, integer *, integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen);
extern int dlasrt_(char *, integer *, doublereal *, integer *, ftnlen);
doublereal orgnrm;
integer givnum, givptr, smlszp;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
@ -302,10 +69,7 @@ f"> */
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
@ -318,38 +82,26 @@ f"> */
xerbla_((char *)"DLALSD", &i__1, (ftnlen)6);
return 0;
}
eps = dlamch_((char *)"Epsilon", (ftnlen)7);
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.) {
rcnd = eps;
} else {
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.) {
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (
ftnlen)1);
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1);
} else {
*rank = 1;
dlascl_((char *)"G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[b_offset], ldb, info,
(ftnlen)1);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
@ -358,13 +110,11 @@ f"> */
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1) {
drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
c__1, &cs, &sn);
drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &c__1, &cs, &sn);
} else {
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
@ -373,37 +123,25 @@ f"> */
for (j = 1; j <= i__2; ++j) {
cs = work[(j << 1) - 1];
sn = work[j * 2];
drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
b_dim1], &c__1, &cs, &sn);
/* L20: */
drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * b_dim1], &c__1, &cs,
&sn);
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1);
if (orgnrm == 0.) {
dlaset_((char *)"A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1);
return 0;
}
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info, (
ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
info, (ftnlen)1);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, info, (ftnlen)1);
if (*n <= *smlsiz) {
nwork = *n * *n + 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, &
work[1], n, &b[b_offset], ldb, &work[nwork], info, (ftnlen)1);
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);
if (*info != 0) {
return 0;
}
@ -411,37 +149,23 @@ f"> */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb,
(ftnlen)1);
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb, (ftnlen)1);
} else {
dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
i__ + b_dim1], ldb, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[i__ + b_dim1], ldb,
info, (ftnlen)1);
++(*rank);
}
/* L40: */
}
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);
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);
dlacpy_((char *)"A", n, nrhs, &work[nwork], n, &b[b_offset], ldb, (ftnlen)1);
/* Unscale. */
dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, 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, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
log(2.)) + 1;
nlvl = (integer)(log((doublereal)(*n) / (doublereal)(*smlsiz + 1)) / log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
@ -453,55 +177,35 @@ f"> */
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_lmp_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
@ -511,80 +215,50 @@ f"> */
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */
dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_((char *)"A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n, (ftnlen)1);
dlasdq_((char *)"U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
st], &work[vt + st1], n, &work[nwork], n, &b[st +
b_dim1], ldb, &work[nwork], info, (ftnlen)1);
dlaset_((char *)"A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], n, (ftnlen)1);
dlasdq_((char *)"U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[st], &work[vt + st1],
n, &work[nwork], n, &b[st + b_dim1], ldb, &work[nwork], info, (ftnlen)1);
if (*info != 0) {
return 0;
}
dlacpy_((char *)"A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
st1], n, (ftnlen)1);
dlacpy_((char *)"A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n, (ftnlen)1);
} else {
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
work[difl + st1], &work[difr + st1], &work[z__ + st1],
&work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum +
st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info);
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &work[u + st1], n,
&work[vt + st1], &iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr + st1],
&iwork[givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
work[bxst], n, &work[u + st1], n, &work[vt + st1], &
iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
work[givnum + st1], &work[c__ + st1], &work[s + st1],
&work[nwork], &iwork[iwk], info);
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &work[bxst], n,
&work[u + st1], n, &work[vt + st1], &iwork[k + st1], &work[difl + st1],
&work[difr + st1], &work[z__ + st1], &work[poles + st1],
&iwork[givptr + st1], &iwork[givcol + st1], n, &iwork[perm + st1],
&work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol) {
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n, (
ftnlen)1);
dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n, (ftnlen)1);
} else {
++(*rank);
dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[bx + i__ - 1], n, info,
(ftnlen)1);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
@ -595,38 +269,24 @@ f"> */
if (nsize == 1) {
dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
} else if (nsize <= *smlsiz) {
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, (
ftnlen)1);
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, (ftnlen)1);
} else {
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
k + st1], &work[difl + st1], &work[difr + st1], &work[z__
+ st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
iwk], info);
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + b_dim1], ldb,
&work[u + st1], n, &work[vt + st1], &iwork[k + st1], &work[difl + st1],
&work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1],
&iwork[givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info, (
ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, 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,
info, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1);
return 0;
/* End of DLALSD */
} /* dlalsd_ */
}
#ifdef __cplusplus
}
}
#endif

59
lib/linalg/dlamc3.cpp
View File

@ -1,68 +1,13 @@
/* static/dlamc3.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAMC3 */
/* > \details */
/* > \b Purpose: */
/* > \verbatim */
/* > DLAMC3 is intended to force A and B to be stored prior to doing */
/* > the addition of A and B , for use in situations where optimizers */
/* > might hold one of these in a register. */
/* > \endverbatim */
/* > \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ.
of Colorado Denver and NAG Ltd.. */
/* > \date December 2016 */
/* > \ingroup auxOTHERauxiliary */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is a DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] B */
/* > \verbatim */
/* > B is a DOUBLE PRECISION */
/* > The values A and B. */
/* > \endverbatim */
/* > */
doublereal dlamc3_(doublereal *a, doublereal *b)
{
/* System generated locals */
doublereal ret_val;
/* -- LAPACK auxiliary routine (version 3.7.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2010 */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Executable Statements .. */
ret_val = *a + *b;
return ret_val;
/* End of DLAMC3 */
} /* dlamc3_ */
}
#ifdef __cplusplus
}
}
#endif

38
lib/linalg/dlamch.cpp
View File

@ -12,34 +12,34 @@ extern "C" {
doublereal dlamch_(const char *cmach)
{
if (!cmach) return 0.0;
char select = toupper(*cmach);
if (!cmach) return 0.0;
char select = toupper(*cmach);
// BLAS assumes rounding not truncation => epsilon is half
const double eps = 0.5 * std::numeric_limits<double>::epsilon();
if (select == 'E') return eps;
// BLAS assumes rounding not truncation => epsilon is half
const double eps = 0.5 * std::numeric_limits<double>::epsilon();
if (select == 'E') return eps;
double min = std::numeric_limits<double>::min();
const double max = std::numeric_limits<double>::max();
double small = 1.0 / max;
if (small >= min) min = small * (1.0 + eps);
if (select == 'S') return min;
double min = std::numeric_limits<double>::min();
const double max = std::numeric_limits<double>::max();
double small = 1.0 / max;
if (small >= min) min = small * (1.0 + eps);
if (select == 'S') return min;
const double radix = std::numeric_limits<double>::radix;
if (select == 'B') return radix;
const double radix = std::numeric_limits<double>::radix;
if (select == 'B') return radix;
if (select == 'P') return eps * radix;
if (select == 'P') return eps * radix;
if (select == 'N') return std::numeric_limits<double>::digits;
if (select == 'N') return std::numeric_limits<double>::digits;
if (select == 'M') return std::numeric_limits<double>::min_exponent;
if (select == 'M') return std::numeric_limits<double>::min_exponent;
if (select == 'U') return min;
if (select == 'U') return min;
if (select == 'L') return std::numeric_limits<double>::max_exponent;
if (select == 'L') return std::numeric_limits<double>::max_exponent;
if (select == 'O') return max;
if (select == 'O') return max;
return 0.0;
return 0.0;
}
}

154
lib/linalg/dlamrg.cpp
View File

@ -1,151 +1,13 @@
/* fortran/dlamrg.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a
single set sorted in ascending order. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAMRG + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlamrg.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlamrg.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlamrg.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) */
/* .. Scalar Arguments .. */
/* INTEGER DTRD1, DTRD2, N1, N2 */
/* .. */
/* .. Array Arguments .. */
/* INTEGER INDEX( * ) */
/* DOUBLE PRECISION A( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAMRG will create a permutation list which will merge the elements */
/* > of A (which is composed of two independently sorted sets) into a */
/* > single set which is sorted in ascending order. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N1 */
/* > \verbatim */
/* > N1 is INTEGER */
/* > \endverbatim */
/* > */
/* > \param[in] N2 */
/* > \verbatim */
/* > N2 is INTEGER */
/* > These arguments contain the respective lengths of the two */
/* > sorted lists to be merged. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (N1+N2) */
/* > The first N1 elements of A contain a list of numbers which */
/* > are sorted in either ascending or descending order. Likewise */
/* > for the final N2 elements. */
/* > \endverbatim */
/* > */
/* > \param[in] DTRD1 */
/* > \verbatim */
/* > DTRD1 is INTEGER */
/* > \endverbatim */
/* > */
/* > \param[in] DTRD2 */
/* > \verbatim */
/* > DTRD2 is INTEGER */
/* > These are the strides to be taken through the array A. */
/* > Allowable strides are 1 and -1. They indicate whether a */
/* > subset of A is sorted in ascending (DTRDx = 1) or descending */
/* > (DTRDx = -1) order. */
/* > \endverbatim */
/* > */
/* > \param[out] INDEX */
/* > \verbatim */
/* > INDEX is INTEGER array, dimension (N1+N2) */
/* > On exit this array will contain a permutation such that */
/* > if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be */
/* > sorted in ascending order. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer
*dtrd1, integer *dtrd2, integer *index)
int dlamrg_(integer *n1, integer *n2, doublereal *a, integer *dtrd1, integer *dtrd2, integer *index)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, ind1, ind2, n1sv, n2sv;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--index;
--a;
/* Function Body */
n1sv = *n1;
n2sv = *n2;
if (*dtrd1 > 0) {
@ -159,7 +21,6 @@ f"> */
ind2 = *n1 + *n2;
}
i__ = 1;
/* while ( (N1SV > 0) & (N2SV > 0) ) */
L10:
if (n1sv > 0 && n2sv > 0) {
if (a[ind1] <= a[ind2]) {
@ -175,32 +36,23 @@ L10:
}
goto L10;
}
/* end while */
if (n1sv == 0) {
i__1 = n2sv;
for (n1sv = 1; n1sv <= i__1; ++n1sv) {
index[i__] = ind2;
++i__;
ind2 += *dtrd2;
/* L20: */
}
} else {
/* N2SV .EQ. 0 */
i__1 = n1sv;
for (n2sv = 1; n2sv <= i__1; ++n2sv) {
index[i__] = ind1;
++i__;
ind1 += *dtrd1;
/* L30: */
}
}
return 0;
/* End of DLAMRG */
} /* dlamrg_ */
}
#ifdef __cplusplus
}
}
#endif

210
lib/linalg/dlange.cpp
View File

@ -1,196 +1,27 @@
/* fortran/dlange.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \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. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLANGE + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlange.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlange.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlange.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) */
/* .. Scalar Arguments .. */
/* CHARACTER NORM */
/* INTEGER LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLANGE returns the value of the one norm, or the Frobenius norm, or */
/* > the infinity norm, or the element of largest absolute value of a */
/* > real matrix A. */
/* > \endverbatim */
/* > */
/* > \return DLANGE */
/* > \verbatim */
/* > */
/* > DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* > ( */
/* > ( norm1(A), NORM = '1', 'O' or 'o' */
/* > ( */
/* > ( normI(A), NORM = 'I' or 'i' */
/* > ( */
/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* > */
/* > where norm1 denotes the one norm of a matrix (maximum column sum), */
/* > normI denotes the infinity norm of a matrix (maximum row sum) and */
/* > normF denotes the Frobenius norm of a matrix (square root of sum of */
/* > squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] NORM */
/* > \verbatim */
/* > NORM is CHARACTER*1 */
/* > Specifies the value to be returned in DLANGE as described */
/* > above. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. When M = 0, */
/* > DLANGE is set to zero. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. When N = 0, */
/* > DLANGE is set to zero. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > The m by n matrix A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(M,1). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* > where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
/* > referenced. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGEauxiliary */
/* ===================================================================== */
doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
*lda, doublereal *work, ftnlen norm_len)
doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer *lda,
doublereal *work, ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal sum, temp, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
extern int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0) {
if (min(*m, *n) == 0) {
value = 0.;
} else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
@ -200,15 +31,9 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
if (value < temp || disnan_(&temp)) {
value = temp;
}
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
} else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') {
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
@ -216,30 +41,22 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L30: */
}
if (value < sum || disnan_(&sum)) {
value = sum;
}
/* L40: */
}
} else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *m;
@ -248,30 +65,19 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
if (value < temp || disnan_(&temp)) {
value = temp;
}
/* L80: */
}
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (ftnlen)1, (ftnlen)1)) {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGE */
} /* dlange_ */
}
#ifdef __cplusplus
}
}
#endif

188
lib/linalg/dlanst.cpp
View File

@ -1,180 +1,24 @@
/* fortran/dlanst.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele
ment of largest absolute value of a real symmetric tridiagonal matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLANST + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlanst.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlanst.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlanst.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) */
/* .. Scalar Arguments .. */
/* CHARACTER NORM */
/* INTEGER N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( * ), E( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLANST returns the value of the one norm, or the Frobenius norm, or */
/* > the infinity norm, or the element of largest absolute value of a */
/* > real symmetric tridiagonal matrix A. */
/* > \endverbatim */
/* > */
/* > \return DLANST */
/* > \verbatim */
/* > */
/* > DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* > ( */
/* > ( norm1(A), NORM = '1', 'O' or 'o' */
/* > ( */
/* > ( normI(A), NORM = 'I' or 'i' */
/* > ( */
/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* > */
/* > where norm1 denotes the one norm of a matrix (maximum column sum), */
/* > normI denotes the infinity norm of a matrix (maximum row sum) and */
/* > normF denotes the Frobenius norm of a matrix (square root of sum of */
/* > squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] NORM */
/* > \verbatim */
/* > NORM is CHARACTER*1 */
/* > Specifies the value to be returned in DLANST as described */
/* > above. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix A. N >= 0. When N = 0, DLANST is */
/* > set to zero. */
/* > \endverbatim */
/* > */
/* > \param[in] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > The diagonal elements of A. */
/* > \endverbatim */
/* > */
/* > \param[in] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (N-1) */
/* > The (n-1) sub-diagonal or super-diagonal elements of A. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
ftnlen norm_len)
doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, ftnlen norm_len)
{
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal sum, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal anorm;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
extern int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *);
--e;
--d__;
/* Function Body */
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
anorm = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
@ -186,13 +30,9 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
if (anorm < sum || disnan_(&sum)) {
anorm = sum;
}
/* L10: */
}
} else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1' || lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
/* Find norm1(A). */
} else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1' ||
lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) {
if (*n == 1) {
anorm = abs(d__[1]);
} else {
@ -203,19 +43,14 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
}
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2)
) + (d__3 = e[i__ - 1], abs(d__3));
sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2)) +
(d__3 = e[i__ - 1], abs(d__3));
if (anorm < sum || disnan_(&sum)) {
anorm = sum;
}
/* L20: */
}
}
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (ftnlen)1, (ftnlen)1)) {
scale = 0.;
sum = 1.;
if (*n > 1) {
@ -226,14 +61,9 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e,
dlassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of DLANST */
} /* dlanst_ */
}
#ifdef __cplusplus
}
}
#endif

217
lib/linalg/dlansy.cpp
View File

@ -1,204 +1,27 @@
/* fortran/dlansy.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele
ment of largest absolute value of a real symmetric matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLANSY + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlansy.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlansy.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlansy.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) */
/* .. Scalar Arguments .. */
/* CHARACTER NORM, UPLO */
/* INTEGER LDA, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLANSY returns the value of the one norm, or the Frobenius norm, or */
/* > the infinity norm, or the element of largest absolute value of a */
/* > real symmetric matrix A. */
/* > \endverbatim */
/* > */
/* > \return DLANSY */
/* > \verbatim */
/* > */
/* > DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* > ( */
/* > ( norm1(A), NORM = '1', 'O' or 'o' */
/* > ( */
/* > ( normI(A), NORM = 'I' or 'i' */
/* > ( */
/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* > */
/* > where norm1 denotes the one norm of a matrix (maximum column sum), */
/* > normI denotes the infinity norm of a matrix (maximum row sum) and */
/* > normF denotes the Frobenius norm of a matrix (square root of sum of */
/* > squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] NORM */
/* > \verbatim */
/* > NORM is CHARACTER*1 */
/* > Specifies the value to be returned in DLANSY as described */
/* > above. */
/* > \endverbatim */
/* > */
/* > \param[in] UPLO */
/* > \verbatim */
/* > UPLO is CHARACTER*1 */
/* > Specifies whether the upper or lower triangular part of the */
/* > symmetric matrix A is to be referenced. */
/* > = 'U': Upper triangular part of A is referenced */
/* > = 'L': Lower triangular part of A is referenced */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix A. N >= 0. When N = 0, DLANSY is */
/* > set to zero. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > The symmetric matrix A. If UPLO = 'U', the leading n by n */
/* > upper triangular part of A contains the upper triangular part */
/* > of the matrix A, and the strictly lower triangular part of A */
/* > is not referenced. If UPLO = 'L', the leading n by n lower */
/* > triangular part of A contains the lower triangular part of */
/* > the matrix A, and the strictly upper triangular part of A is */
/* > not referenced. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(N,1). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
/* > WORK is not referenced. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleSYauxiliary */
/* ===================================================================== */
doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
*lda, doublereal *work, ftnlen norm_len, ftnlen uplo_len)
doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer *lda,
doublereal *work, ftnlen norm_len, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
extern int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
@ -209,9 +32,7 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
if (value < sum || disnan_(&sum)) {
value = sum;
}
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
@ -222,16 +43,11 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
if (value < sum || disnan_(&sum)) {
value = sum;
}
/* L30: */
}
/* L40: */
}
}
} else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", (
ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is symmetric). */
} else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) ||
*(unsigned char *)norm == '1') {
value = 0.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
@ -242,10 +58,8 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1));
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
@ -253,13 +67,11 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
if (value < sum || disnan_(&sum)) {
value = sum;
}
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
@ -269,19 +81,13 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
sum += absa;
work[i__] += absa;
/* L90: */
}
if (value < sum || disnan_(&sum)) {
value = sum;
}
/* L100: */
}
}
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
} else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (ftnlen)1, (ftnlen)1)) {
scale = 0.;
sum = 1.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
@ -289,14 +95,12 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L110: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
@ -304,14 +108,9 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
dlassq_(n, &a[a_offset], &i__1, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANSY */
} /* dlansy_ */
}
#ifdef __cplusplus
}
}
#endif

121
lib/linalg/dlapy2.cpp
View File

@ -1,121 +1,16 @@
/* fortran/dlapy2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAPY2 returns sqrt(x2+y2). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAPY2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlapy2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlapy2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlapy2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION X, Y */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary */
/* > overflow and unnecessary underflow. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] Y */
/* > \verbatim */
/* > Y is DOUBLE PRECISION */
/* > X and Y specify the values x and y. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
doublereal dlapy2_(doublereal *x, doublereal *y)
{
/* System generated locals */
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
logical x_is_nan__, y_is_nan__;
doublereal w, z__, xabs, yabs;
extern doublereal dlamch_(char *, ftnlen);
extern logical disnan_(doublereal *);
doublereal hugeval;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
x_is_nan__ = disnan_(x);
y_is_nan__ = disnan_(y);
if (x_is_nan__) {
@ -125,26 +20,20 @@ doublereal dlapy2_(doublereal *x, doublereal *y)
ret_val = *y;
}
hugeval = dlamch_((char *)"Overflow", (ftnlen)8);
if (! (x_is_nan__ || y_is_nan__)) {
if (!(x_is_nan__ || y_is_nan__)) {
xabs = abs(*x);
yabs = abs(*y);
w = max(xabs,yabs);
z__ = min(xabs,yabs);
w = max(xabs, yabs);
z__ = min(xabs, yabs);
if (z__ == 0. || w > hugeval) {
ret_val = w;
} else {
/* Computing 2nd power */
d__1 = z__ / w;
ret_val = w * sqrt(d__1 * d__1 + 1.);
}
}
return ret_val;
/* End of DLAPY2 */
} /* dlapy2_ */
}
#ifdef __cplusplus
}
}
#endif

127
lib/linalg/dlapy3.cpp
View File

@ -1,149 +1,30 @@
/* fortran/dlapy3.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAPY3 returns sqrt(x2+y2+z2). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAPY3 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlapy3.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlapy3.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlapy3.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION X, Y, Z */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause */
/* > unnecessary overflow and unnecessary underflow. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] Y */
/* > \verbatim */
/* > Y is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION */
/* > X, Y and Z specify the values x, y and z. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__)
{
/* System generated locals */
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal w, xabs, yabs, zabs;
extern doublereal dlamch_(char *, ftnlen);
doublereal hugeval;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
hugeval = dlamch_((char *)"Overflow", (ftnlen)8);
xabs = abs(*x);
yabs = abs(*y);
zabs = abs(*z__);
/* Computing MAX */
d__1 = max(xabs,yabs);
w = max(d__1,zabs);
d__1 = max(xabs, yabs);
w = max(d__1, zabs);
if (w == 0. || w > hugeval) {
/* W can be zero for max(0,nan,0) */
/* adding all three entries together will make sure */
/* NaN will not disappear. */
ret_val = xabs + yabs + zabs;
} else {
/* Computing 2nd power */
d__1 = xabs / w;
/* Computing 2nd power */
d__2 = yabs / w;
/* Computing 2nd power */
d__3 = zabs / w;
ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3);
}
return ret_val;
/* End of DLAPY3 */
} /* dlapy3_ */
}
#ifdef __cplusplus
}
}
#endif

236
lib/linalg/dlarf.cpp
View File

@ -1,209 +1,34 @@
/* fortran/dlarf.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b4 = 1.;
static doublereal c_b5 = 0.;
static integer c__1 = 1;
/* > \brief \b DLARF applies an elementary reflector to a general rectangular matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLARF + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarf.f
"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarf.f
"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarf.f
"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
/* .. Scalar Arguments .. */
/* CHARACTER SIDE */
/* INTEGER INCV, LDC, M, N */
/* DOUBLE PRECISION TAU */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLARF applies a real elementary reflector H to a real m by n matrix */
/* > C, from either the left or the right. H is represented in the form */
/* > */
/* > H = I - tau * v * v**T */
/* > */
/* > where tau is a real scalar and v is a real vector. */
/* > */
/* > If tau = 0, then H is taken to be the unit matrix. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > = 'L': form H * C */
/* > = 'R': form C * H */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix C. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix C. */
/* > \endverbatim */
/* > */
/* > \param[in] V */
/* > \verbatim */
/* > V is DOUBLE PRECISION array, dimension */
/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* > The vector v in the representation of H. V is not used if */
/* > TAU = 0. */
/* > \endverbatim */
/* > */
/* > \param[in] INCV */
/* > \verbatim */
/* > INCV is INTEGER */
/* > The increment between elements of v. INCV <> 0. */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION */
/* > The value tau in the representation of H. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
/* > On entry, the m by n matrix C. */
/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* > or C * H if SIDE = 'R'. */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > The leading dimension of the array C. LDC >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension */
/* > (N) if SIDE = 'L' */
/* > or (M) if SIDE = 'R' */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,
integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
doublereal *work, ftnlen side_len)
int dlarf_(char *side, integer *m, integer *n, doublereal *v, integer *incv, doublereal *tau,
doublereal *c__, integer *ldc, doublereal *work, ftnlen side_len)
{
/* System generated locals */
integer c_dim1, c_offset;
doublereal d__1;
/* Local variables */
integer i__;
logical applyleft;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern int dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen);
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen);
integer lastc, lastv;
extern integer iladlc_(integer *, integer *, doublereal *, integer *),
iladlr_(integer *, integer *, doublereal *, integer *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
iladlr_(integer *, integer *, doublereal *, integer *);
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
applyleft = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
lastv = 0;
lastc = 0;
if (*tau != 0.) {
/* Set up variables for scanning V. LASTV begins pointing to the end */
/* of V. */
if (applyleft) {
lastv = *m;
} else {
@ -214,62 +39,33 @@ static integer c__1 = 1;
} else {
i__ = 1;
}
/* Look for the last non-zero row in V. */
while(lastv > 0 && v[i__] == 0.) {
while (lastv > 0 && v[i__] == 0.) {
--lastv;
i__ -= *incv;
}
if (applyleft) {
/* Scan for the last non-zero column in C(1:lastv,:). */
lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
} else {
/* Scan for the last non-zero row in C(:,1:lastv). */
lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
}
}
/* Note that lastc.eq.0 renders the BLAS operations null; no special */
/* case is needed at this level. */
if (applyleft) {
/* Form H * C */
if (lastv > 0) {
/* 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, &
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 */
dgemv_((char *)"Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &v[1], incv, &c_b5,
&work[1], &c__1, (ftnlen)9);
d__1 = -(*tau);
dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[
c_offset], ldc);
dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc);
}
} else {
/* Form C * H */
if (lastv > 0) {
/* 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,
&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 */
dgemv_((char *)"No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, &v[1], incv, &c_b5,
&work[1], &c__1, (ftnlen)12);
d__1 = -(*tau);
dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
c_offset], ldc);
dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc);
}
}
return 0;
/* End of DLARF */
} /* dlarf_ */
}
#ifdef __cplusplus
}
}
#endif

831
lib/linalg/dlarfb.cpp
View File

File diff suppressed because it is too large Load Diff

191
lib/linalg/dlarfg.cpp
View File

@ -1,203 +1,36 @@
/* fortran/dlarfg.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLARFG generates an elementary reflector (Householder matrix). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLARFG + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfg.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfg.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfg.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) */
/* .. Scalar Arguments .. */
/* INTEGER INCX, N */
/* DOUBLE PRECISION ALPHA, TAU */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION X( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLARFG generates a real elementary reflector H of order n, such */
/* > that */
/* > */
/* > H * ( alpha ) = ( beta ), H**T * H = I. */
/* > ( x ) ( 0 ) */
/* > */
/* > where alpha and beta are scalars, and x is an (n-1)-element real */
/* > vector. H is represented in the form */
/* > */
/* > H = I - tau * ( 1 ) * ( 1 v**T ) , */
/* > ( v ) */
/* > */
/* > where tau is a real scalar and v is a real (n-1)-element */
/* > vector. */
/* > */
/* > If the elements of x are all zero, then tau = 0 and H is taken to be */
/* > the unit matrix. */
/* > */
/* > Otherwise 1 <= tau <= 2. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the elementary reflector. */
/* > \endverbatim */
/* > */
/* > \param[in,out] ALPHA */
/* > \verbatim */
/* > ALPHA is DOUBLE PRECISION */
/* > On entry, the value alpha. */
/* > On exit, it is overwritten with the value beta. */
/* > \endverbatim */
/* > */
/* > \param[in,out] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION array, dimension */
/* > (1+(N-2)*abs(INCX)) */
/* > On entry, the vector x. */
/* > On exit, it is overwritten with the vector v. */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > The increment between elements of X. INCX > 0. */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION */
/* > The value tau. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x,
integer *incx, doublereal *tau)
int dlarfg_(integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *tau)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_lmp_sign(doublereal *, doublereal *);
/* Local variables */
integer j, knt;
doublereal beta;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen);
doublereal safmin, rsafmn;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
*tau = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
if (xnorm == 0.) {
/* H = I */
*tau = 0.;
} else {
/* general case */
d__1 = dlapy2_(alpha, &xnorm);
beta = -d_lmp_sign(&d__1, alpha);
safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1);
knt = 0;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1. / safmin;
L10:
L10:
++knt;
i__1 = *n - 1;
dscal_(&i__1, &rsafmn, &x[1], incx);
@ -206,9 +39,6 @@ L10:
if (abs(beta) < safmin && knt < 20) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
d__1 = dlapy2_(alpha, &xnorm);
@ -218,23 +48,14 @@ L10:
i__1 = *n - 1;
d__1 = 1. / (*alpha - beta);
dscal_(&i__1, &d__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
/* L20: */
}
*alpha = beta;
}
return 0;
/* End of DLARFG */
} /* dlarfg_ */
}
#ifdef __cplusplus
}
}
#endif

336
lib/linalg/dlarft.cpp
View File

@ -1,233 +1,21 @@
/* static/dlarft.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b7 = 1.;
/* > \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLARFT + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarft.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarft.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarft.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) */
/* .. Scalar Arguments .. */
/* CHARACTER DIRECT, STOREV */
/* INTEGER K, LDT, LDV, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLARFT forms the triangular factor T of a real block reflector H */
/* > of order n, which is defined as a product of k elementary reflectors. */
/* > */
/* > If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* > */
/* > If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* > */
/* > If STOREV = 'C', the vector which defines the elementary reflector */
/* > H(i) is stored in the i-th column of the array V, and */
/* > */
/* > H = I - V * T * V**T */
/* > */
/* > If STOREV = 'R', the vector which defines the elementary reflector */
/* > H(i) is stored in the i-th row of the array V, and */
/* > */
/* > H = I - V**T * T * V */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] DIRECT */
/* > \verbatim */
/* > DIRECT is CHARACTER*1 */
/* > Specifies the order in which the elementary reflectors are */
/* > multiplied to form the block reflector: */
/* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* > \endverbatim */
/* > */
/* > \param[in] STOREV */
/* > \verbatim */
/* > STOREV is CHARACTER*1 */
/* > Specifies how the vectors which define the elementary */
/* > reflectors are stored (see also Further Details): */
/* > = 'C': columnwise */
/* > = 'R': rowwise */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the block reflector H. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The order of the triangular factor T (= the number of */
/* > elementary reflectors). K >= 1. */
/* > \endverbatim */
/* > */
/* > \param[in] V */
/* > \verbatim */
/* > V is DOUBLE PRECISION array, dimension */
/* > (LDV,K) if STOREV = 'C' */
/* > (LDV,N) if STOREV = 'R' */
/* > The matrix V. See further details. */
/* > \endverbatim */
/* > */
/* > \param[in] LDV */
/* > \verbatim */
/* > LDV is INTEGER */
/* > The leading dimension of the array V. */
/* > If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i). */
/* > \endverbatim */
/* > */
/* > \param[out] T */
/* > \verbatim */
/* > T is DOUBLE PRECISION array, dimension (LDT,K) */
/* > The k by k triangular factor T of the block reflector. */
/* > If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* > lower triangular. The rest of the array is not used. */
/* > \endverbatim */
/* > */
/* > \param[in] LDT */
/* > \verbatim */
/* > LDT is INTEGER */
/* > The leading dimension of the array T. LDT >= K. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > The shape of the matrix V and the storage of the vectors which define */
/* > the H(i) is best illustrated by the following example with n = 5 and */
/* > k = 3. The elements equal to 1 are not stored. */
/* > */
/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* > */
/* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
/* > ( v1 1 ) ( 1 v2 v2 v2 ) */
/* > ( v1 v2 1 ) ( 1 v3 v3 ) */
/* > ( v1 v2 v3 ) */
/* > ( v1 v2 v3 ) */
/* > */
/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* > */
/* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
/* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
/* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
/* > ( 1 v3 ) */
/* > ( 1 ) */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
integer *ldt, ftnlen direct_len, ftnlen storev_len)
int dlarft_(char *direct, char *storev, integer *n, integer *k, doublereal *v, integer *ldv,
doublereal *tau, doublereal *t, integer *ldt, ftnlen direct_len, ftnlen storev_len)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j, prevlastv;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen);
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen);
integer lastv;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
extern int dtrmv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen);
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
@ -235,87 +23,65 @@ f"> */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
prevlastv = *n;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
prevlastv = max(i__,prevlastv);
prevlastv = max(i__, prevlastv);
if (tau[i__] == 0.) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = 0.;
}
} else {
/* general case */
if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) {
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) {
if (v[lastv + i__ * v_dim1] != 0.) {
goto L219;
}
}
L219:
L219:
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1];
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */
j = min(lastv, prevlastv);
i__2 = j - i__;
i__3 = i__ - 1;
d__1 = -tau[i__];
dgemv_((char *)"Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 +
v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &
c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)9);
dgemv_((char *)"Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + v_dim1], ldv,
&v[i__ + 1 + i__ * v_dim1], &c__1, &c_b7, &t[i__ * t_dim1 + 1], &c__1,
(ftnlen)9);
} else {
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) {
if (v[i__ + lastv * v_dim1] != 0.) {
goto L235;
}
}
L235:
L235:
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1];
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */
j = min(lastv, prevlastv);
i__2 = i__ - 1;
i__3 = j - i__;
d__1 = -tau[i__];
dgemv_((char *)"No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) *
v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1],
ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)
12);
dgemv_((char *)"No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * v_dim1 + 1], ldv,
&v[i__ + (i__ + 1) * v_dim1], ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1,
(ftnlen)12);
}
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
dtrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)
5, (ftnlen)12, (ftnlen)8);
dtrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8);
t[i__ + i__ * t_dim1] = tau[i__];
if (i__ > 1) {
prevlastv = max(prevlastv,lastv);
prevlastv = max(prevlastv, lastv);
} else {
prevlastv = lastv;
}
@ -325,79 +91,57 @@ L235:
prevlastv = 1;
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.;
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) {
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[lastv + i__ * v_dim1] != 0.) {
goto L280;
}
}
L280:
L280:
i__1 = *k;
for (j = i__ + 1; j <= i__1; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__
+ j * v_dim1];
t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ + j * v_dim1];
}
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) */
j = max(lastv, prevlastv);
i__1 = *n - *k + i__ - j;
i__2 = *k - i__;
d__1 = -tau[i__];
dgemv_((char *)"Transpose", &i__1, &i__2, &d__1, &v[j + (i__
+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1], &
c__1, (ftnlen)9);
dgemv_((char *)"Transpose", &i__1, &i__2, &d__1, &v[j + (i__ + 1) * v_dim1], ldv,
&v[j + i__ * v_dim1], &c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1],
&c__1, (ftnlen)9);
} else {
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[i__ + lastv * v_dim1] != 0.) {
goto L296;
}
}
L296:
L296:
i__1 = *k;
for (j = i__ + 1; j <= i__1; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k
+ i__) * v_dim1];
t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k + i__) * v_dim1];
}
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 */
j = max(lastv, prevlastv);
i__1 = *k - i__;
i__2 = *n - *k + i__ - j;
d__1 = -tau[i__];
dgemv_((char *)"No transpose", &i__1, &i__2, &d__1, &v[i__ +
1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1,
(ftnlen)12);
dgemv_((char *)"No transpose", &i__1, &i__2, &d__1, &v[i__ + 1 + j * v_dim1], ldv,
&v[i__ + j * v_dim1], ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1,
(ftnlen)12);
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
dtrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8)
;
dtrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1,
&t[i__ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1], &c__1,
(ftnlen)5, (ftnlen)12, (ftnlen)8);
if (i__ > 1) {
prevlastv = min(prevlastv,lastv);
prevlastv = min(prevlastv, lastv);
} else {
prevlastv = lastv;
}
@ -407,11 +151,7 @@ L296:
}
}
return 0;
/* End of DLARFT */
} /* dlarft_ */
}
#ifdef __cplusplus
}
}
#endif

184
lib/linalg/dlartg.cpp
View File

@ -1,175 +1,24 @@
/* fortran/dlartg.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLARTG generates a plane rotation with real cosine and real sine. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLARTG + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartg.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartg.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartg.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLARTG( F, G, CS, SN, R ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION CS, F, G, R, SN */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLARTG generate a plane rotation so that */
/* > */
/* > [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */
/* > [ -SN CS ] [ G ] [ 0 ] */
/* > */
/* > This is a slower, more accurate version of the BLAS1 routine DROTG, */
/* > with the following other differences: */
/* > F and G are unchanged on return. */
/* > If G=0, then CS=1 and SN=0. */
/* > If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */
/* > floating point operations (saves work in DBDSQR when */
/* > there are zeros on the diagonal). */
/* > */
/* > If F exceeds G in magnitude, CS will be positive. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] F */
/* > \verbatim */
/* > F is DOUBLE PRECISION */
/* > The first component of vector to be rotated. */
/* > \endverbatim */
/* > */
/* > \param[in] G */
/* > \verbatim */
/* > G is DOUBLE PRECISION */
/* > The second component of vector to be rotated. */
/* > \endverbatim */
/* > */
/* > \param[out] CS */
/* > \verbatim */
/* > CS is DOUBLE PRECISION */
/* > The cosine of the rotation. */
/* > \endverbatim */
/* > */
/* > \param[out] SN */
/* > \verbatim */
/* > SN is DOUBLE PRECISION */
/* > The sine of the rotation. */
/* > \endverbatim */
/* > */
/* > \param[out] R */
/* > \verbatim */
/* > R is DOUBLE PRECISION */
/* > The nonzero component of the rotated vector. */
/* > */
/* > This version has a few statements commented out for thread safety */
/* > (machine parameters are computed on each entry). 10 feb 03, SJH. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \date December 2016 */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs,
doublereal *sn, doublereal *r__)
int dlartg_(doublereal *f, doublereal *g, doublereal *cs, doublereal *sn, doublereal *r__)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal), pow_lmp_di(doublereal *, integer *), sqrt(doublereal);
/* Local variables */
integer i__;
doublereal f1, g1, eps, scale;
integer count;
doublereal safmn2, safmx2;
extern doublereal dlamch_(char *, ftnlen);
doublereal safmin;
/* -- LAPACK auxiliary routine (version 3.7.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* December 2016 */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
/* .. */
/* .. Data statements .. */
/* DATA FIRST / .TRUE. / */
/* .. */
/* .. Executable Statements .. */
/* IF( FIRST ) THEN */
safmin = dlamch_((char *)"S", (ftnlen)1);
eps = dlamch_((char *)"E", (ftnlen)1);
d__1 = dlamch_((char *)"B", (ftnlen)1);
i__1 = (integer) (log(safmin / eps) / log(dlamch_((char *)"B", (ftnlen)1)) / 2.);
i__1 = (integer)(log(safmin / eps) / log(dlamch_((char *)"B", (ftnlen)1)) / 2.);
safmn2 = pow_lmp_di(&d__1, &i__1);
safmx2 = 1. / safmn2;
/* FIRST = .FALSE. */
/* END IF */
if (*g == 0.) {
*cs = 1.;
*sn = 0.;
@ -181,24 +30,20 @@ f"> */
} else {
f1 = *f;
g1 = *g;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
scale = max(d__1, d__2);
if (scale >= safmx2) {
count = 0;
L10:
L10:
++count;
f1 *= safmn2;
g1 *= safmn2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
scale = max(d__1, d__2);
if (scale >= safmx2) {
goto L10;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
@ -206,23 +51,19 @@ L10:
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmx2;
/* L20: */
}
} else if (scale <= safmn2) {
count = 0;
L30:
L30:
++count;
f1 *= safmx2;
g1 *= safmx2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
scale = max(d__1, d__2);
if (scale <= safmn2) {
goto L30;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
@ -230,12 +71,9 @@ L30:
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmn2;
/* L40: */
}
} else {
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
@ -248,11 +86,7 @@ L30:
}
}
return 0;
/* End of DLARTG */
} /* dlartg_ */
}
#ifdef __cplusplus
}
}
#endif

173
lib/linalg/dlas2.cpp
View File

@ -1,177 +1,29 @@
/* fortran/dlas2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLAS2 computes singular values of a 2-by-2 triangular matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLAS2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlas2.f
"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlas2.f
"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlas2.f
"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION F, G, H, SSMAX, SSMIN */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLAS2 computes the singular values of the 2-by-2 matrix */
/* > [ F G ] */
/* > [ 0 H ]. */
/* > On return, SSMIN is the smaller singular value and SSMAX is the */
/* > larger singular value. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] F */
/* > \verbatim */
/* > F is DOUBLE PRECISION */
/* > The (1,1) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] G */
/* > \verbatim */
/* > G is DOUBLE PRECISION */
/* > The (1,2) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] H */
/* > \verbatim */
/* > H is DOUBLE PRECISION */
/* > The (2,2) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] SSMIN */
/* > \verbatim */
/* > SSMIN is DOUBLE PRECISION */
/* > The smaller singular value. */
/* > \endverbatim */
/* > */
/* > \param[out] SSMAX */
/* > \verbatim */
/* > SSMAX is DOUBLE PRECISION */
/* > The larger singular value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Barring over/underflow, all output quantities are correct to within */
/* > a few units in the last place (ulps), even in the absence of a guard */
/* > digit in addition/subtraction. */
/* > */
/* > In IEEE arithmetic, the code works correctly if one matrix element is */
/* > infinite. */
/* > */
/* > Overflow will not occur unless the largest singular value itself */
/* > overflows, or is within a few ulps of overflow. (On machines with */
/* > partial overflow, like the Cray, overflow may occur if the largest */
/* > singular value is within a factor of 2 of overflow.) */
/* > */
/* > Underflow is harmless if underflow is gradual. Otherwise, results */
/* > may correspond to a matrix modified by perturbations of size near */
/* > the underflow threshold. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__,
doublereal *ssmin, doublereal *ssmax)
int dlas2_(doublereal *f, doublereal *g, doublereal *h__, doublereal *ssmin, doublereal *ssmax)
{
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal c__, fa, ga, ha, as, at, au, fhmn, fhmx;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ==================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
fa = abs(*f);
ga = abs(*g);
ha = abs(*h__);
fhmn = min(fa,ha);
fhmx = max(fa,ha);
fhmn = min(fa, ha);
fhmx = max(fa, ha);
if (fhmn == 0.) {
*ssmin = 0.;
if (fhmx == 0.) {
*ssmax = ga;
} else {
/* Computing 2nd power */
d__1 = min(fhmx,ga) / max(fhmx,ga);
*ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.);
d__1 = min(fhmx, ga) / max(fhmx, ga);
*ssmax = max(fhmx, ga) * sqrt(d__1 * d__1 + 1.);
}
} else {
if (ga < fhmx) {
as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */
d__1 = ga / fhmx;
au = d__1 * d__1;
c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au));
@ -180,19 +32,12 @@ extern "C" {
} else {
au = fhmx / ga;
if (au == 0.) {
/* Avoid possible harmful underflow if exponent range */
/* asymmetric (true SSMIN may not underflow even if */
/* AU underflows) */
*ssmin = fhmn * fhmx / ga;
*ssmax = ga;
} else {
as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */
d__1 = as * au;
/* Computing 2nd power */
d__2 = at * au;
c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.));
*ssmin = fhmn * c__ * au;
@ -202,11 +47,7 @@ extern "C" {
}
}
return 0;
/* End of DLAS2 */
} /* dlas2_ */
}
#ifdef __cplusplus
}
}
#endif

299
lib/linalg/dlascl.cpp
View File

@ -1,172 +1,11 @@
/* fortran/dlascl.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASCL + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlascl.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlascl.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlascl.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER TYPE */
/* INTEGER INFO, KL, KU, LDA, M, N */
/* DOUBLE PRECISION CFROM, CTO */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASCL multiplies the M by N real matrix A by the real scalar */
/* > CTO/CFROM. This is done without over/underflow as long as the final */
/* > result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
/* > A may be full, upper triangular, lower triangular, upper Hessenberg, */
/* > or banded. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] TYPE */
/* > \verbatim */
/* > TYPE is CHARACTER*1 */
/* > TYPE indices the storage type of the input matrix. */
/* > = 'G': A is a full matrix. */
/* > = 'L': A is a lower triangular matrix. */
/* > = 'U': A is an upper triangular matrix. */
/* > = 'H': A is an upper Hessenberg matrix. */
/* > = 'B': A is a symmetric band matrix with lower bandwidth KL */
/* > and upper bandwidth KU and with the only the lower */
/* > half stored. */
/* > = 'Q': A is a symmetric band matrix with lower bandwidth KL */
/* > and upper bandwidth KU and with the only the upper */
/* > half stored. */
/* > = 'Z': A is a band matrix with lower bandwidth KL and upper */
/* > bandwidth KU. See DGBTRF for storage details. */
/* > \endverbatim */
/* > */
/* > \param[in] KL */
/* > \verbatim */
/* > KL is INTEGER */
/* > The lower bandwidth of A. Referenced only if TYPE = 'B', */
/* > 'Q' or 'Z'. */
/* > \endverbatim */
/* > */
/* > \param[in] KU */
/* > \verbatim */
/* > KU is INTEGER */
/* > The upper bandwidth of A. Referenced only if TYPE = 'B', */
/* > 'Q' or 'Z'. */
/* > \endverbatim */
/* > */
/* > \param[in] CFROM */
/* > \verbatim */
/* > CFROM is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in] CTO */
/* > \verbatim */
/* > CTO is DOUBLE PRECISION */
/* > */
/* > The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
/* > without over/underflow if the final result CTO*A(I,J)/CFROM */
/* > can be represented without over/underflow. CFROM must be */
/* > nonzero. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > The matrix to be multiplied by CTO/CFROM. See TYPE for the */
/* > storage type. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. */
/* > If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); */
/* > TYPE = 'B', LDA >= KL+1; */
/* > TYPE = 'Q', LDA >= KU+1; */
/* > TYPE = 'Z', LDA >= 2*KL+KU+1. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > 0 - successful exit */
/* > <0 - if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku,
doublereal *cfrom, doublereal *cto, integer *m, integer *n,
doublereal *a, integer *lda, integer *info, ftnlen type_len)
int dlascl_(char *type__, integer *kl, integer *ku, doublereal *cfrom, doublereal *cto, integer *m,
integer *n, doublereal *a, integer *lda, integer *info, ftnlen type_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */
integer i__, j, k1, k2, k3, k4;
doublereal mul, cto1;
logical done;
@ -177,43 +16,12 @@ f"> */
extern doublereal dlamch_(char *, ftnlen);
doublereal cfromc;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
doublereal bignum, smlnum;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
if (lsame_(type__, (char *)"G", (ftnlen)1, (ftnlen)1)) {
itype = 0;
} else if (lsame_(type__, (char *)"L", (ftnlen)1, (ftnlen)1)) {
@ -231,7 +39,6 @@ f"> */
} else {
itype = -1;
}
if (itype == -1) {
*info = -1;
} else if (*cfrom == 0. || disnan_(cfrom)) {
@ -242,59 +49,43 @@ f"> */
*info = -6;
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
*info = -7;
} else if (itype <= 3 && *lda < max(1,*m)) {
} else if (itype <= 3 && *lda < max(1, *m)) {
*info = -9;
} else if (itype >= 4) {
/* Computing MAX */
i__1 = *m - 1;
if (*kl < 0 || *kl > max(i__1,0)) {
if (*kl < 0 || *kl > max(i__1, 0)) {
*info = -2;
} else /* if(complicated condition) */ {
/* Computing MAX */
} else {
i__1 = *n - 1;
if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
*kl != *ku) {
if (*ku < 0 || *ku > max(i__1, 0) || (itype == 4 || itype == 5) && *kl != *ku) {
*info = -3;
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *ku + 1 ||
itype == 6 && *lda < (*kl << 1) + *ku + 1) {
*info = -9;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DLASCL", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
}
/* Get machine parameters */
smlnum = dlamch_((char *)"S", (ftnlen)1);
bignum = 1. / smlnum;
cfromc = *cfrom;
ctoc = *cto;
L10:
cfrom1 = cfromc * smlnum;
if (cfrom1 == cfromc) {
/* CFROMC is an inf. Multiply by a correctly signed zero for */
/* finite CTOC, or a NaN if CTOC is infinite. */
mul = ctoc / cfromc;
done = TRUE_;
cto1 = ctoc;
} else {
cto1 = ctoc / bignum;
if (cto1 == ctoc) {
/* CTOC is either 0 or an inf. In both cases, CTOC itself */
/* serves as the correct multiplication factor. */
mul = ctoc;
done = TRUE_;
cfromc = 1.;
@ -314,135 +105,81 @@ L10:
}
}
}
if (itype == 0) {
/* Full matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L20: */
}
/* L30: */
}
} else if (itype == 1) {
/* Lower triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L40: */
}
/* L50: */
}
} else if (itype == 2) {
/* Upper triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
i__2 = min(j, *m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L60: */
}
/* L70: */
}
} else if (itype == 3) {
/* Upper Hessenberg matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j + 1;
i__2 = min(i__3,*m);
i__2 = min(i__3, *m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L80: */
}
/* L90: */
}
} else if (itype == 4) {
/* Lower half of a symmetric band matrix */
k3 = *kl + 1;
k4 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
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__) {
a[i__ + j * a_dim1] *= mul;
/* L100: */
}
/* L110: */
}
} else if (itype == 5) {
/* Upper half of a symmetric band matrix */
k1 = *ku + 2;
k3 = *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = k1 - j;
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;
/* L120: */
}
/* L130: */
}
} else if (itype == 6) {
/* Band matrix */
k1 = *kl + *ku + 2;
k2 = *kl + 1;
k3 = (*kl << 1) + *ku + 1;
k4 = *kl + *ku + 1 + *m;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = k1 - j;
/* Computing MIN */
i__4 = k3, i__5 = k4 - j;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
i__2 = min(i__4, i__5);
for (i__ = max(i__3, k2); i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L140: */
}
/* L150: */
}
}
if (! done) {
if (!done) {
goto L10;
}
return 0;
/* End of DLASCL */
} /* dlascl_ */
}
#ifdef __cplusplus
}
}
#endif

629
lib/linalg/dlasd4.cpp
View File

File diff suppressed because it is too large Load Diff

215
lib/linalg/dlasd5.cpp
View File

@ -1,264 +1,67 @@
/* fortran/dlasd5.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modific
ation of a 2-by-2 diagonal matrix. Used by sbdsdc. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASD5 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasd5.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasd5.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasd5.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) */
/* .. Scalar Arguments .. */
/* INTEGER I */
/* DOUBLE PRECISION DSIGMA, RHO */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > This subroutine computes the square root of the I-th eigenvalue */
/* > of a positive symmetric rank-one modification of a 2-by-2 diagonal */
/* > matrix */
/* > */
/* > diag( D ) * diag( D ) + RHO * Z * transpose(Z) . */
/* > */
/* > The diagonal entries in the array D are assumed to satisfy */
/* > */
/* > 0 <= D(i) < D(j) for i < j . */
/* > */
/* > We also assume RHO > 0 and that the Euclidean norm of the vector */
/* > Z is one. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] I */
/* > \verbatim */
/* > I is INTEGER */
/* > The index of the eigenvalue to be computed. I = 1 or I = 2. */
/* > \endverbatim */
/* > */
/* > \param[in] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension ( 2 ) */
/* > The original eigenvalues. We assume 0 <= D(1) < D(2). */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( 2 ) */
/* > The components of the updating vector. */
/* > \endverbatim */
/* > */
/* > \param[out] DELTA */
/* > \verbatim */
/* > DELTA is DOUBLE PRECISION array, dimension ( 2 ) */
/* > Contains (D(j) - sigma_I) in its j-th component. */
/* > The vector DELTA contains the information necessary */
/* > to construct the eigenvectors. */
/* > \endverbatim */
/* > */
/* > \param[in] RHO */
/* > \verbatim */
/* > RHO is DOUBLE PRECISION */
/* > The scalar in the symmetric updating formula. */
/* > \endverbatim */
/* > */
/* > \param[out] DSIGMA */
/* > \verbatim */
/* > DSIGMA is DOUBLE PRECISION */
/* > The computed sigma_I, the I-th updated eigenvalue. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension ( 2 ) */
/* > WORK contains (D(j) + sigma_I) in its j-th component. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ren-Cang Li, Computer Science Division, University of California */
/* > at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__,
doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal *
work)
int dlasd5_(integer *i__, doublereal *d__, doublereal *z__, doublereal *delta, doublereal *rho,
doublereal *dsigma, doublereal *work)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal b, c__, w, del, tau, delsq;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--delta;
--z__;
--d__;
/* Function Body */
del = d__[2] - d__[1];
delsq = del * (d__[2] + d__[1]);
if (*i__ == 1) {
w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] *
z__[1] / (d__[1] * 3. + d__[2])) / del + 1.;
w = *rho * 4. *
(z__[2] * z__[2] / (d__[1] + d__[2] * 3.) -
z__[1] * z__[1] / (d__[1] * 3. + d__[2])) /
del +
1.;
if (w > 0.) {
b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[1] * z__[1] * delsq;
/* B > ZERO, always */
/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */
tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
/* The following TAU is DSIGMA - D( 1 ) */
tau /= d__[1] + sqrt(d__[1] * d__[1] + tau);
*dsigma = d__[1] + tau;
delta[1] = -tau;
delta[2] = del - tau;
work[1] = d__[1] * 2. + tau;
work[2] = d__[1] + tau + d__[2];
/* DELTA( 1 ) = -Z( 1 ) / TAU */
/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */
} else {
b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * delsq;
/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
if (b > 0.) {
tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.));
} else {
tau = (b - sqrt(b * b + c__ * 4.)) / 2.;
}
/* The following TAU is DSIGMA - D( 2 ) */
tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1)));
*dsigma = d__[2] + tau;
delta[1] = -(del + tau);
delta[2] = -tau;
work[1] = d__[1] + tau + d__[2];
work[2] = d__[2] * 2. + tau;
/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
/* DELTA( 2 ) = -Z( 2 ) / TAU */
}
/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
/* DELTA( 1 ) = DELTA( 1 ) / TEMP */
/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
} else {
/* Now I=2 */
b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * delsq;
/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
if (b > 0.) {
tau = (b + sqrt(b * b + c__ * 4.)) / 2.;
} else {
tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.));
}
/* The following TAU is DSIGMA - D( 2 ) */
tau /= d__[2] + sqrt(d__[2] * d__[2] + tau);
*dsigma = d__[2] + tau;
delta[1] = -(del + tau);
delta[2] = -tau;
work[1] = d__[1] + tau + d__[2];
work[2] = d__[2] * 2. + tau;
/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
/* DELTA( 2 ) = -Z( 2 ) / TAU */
/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
/* DELTA( 1 ) = DELTA( 1 ) / TEMP */
/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
}
return 0;
/* End of DLASD5 */
} /* dlasd5_ */
}
#ifdef __cplusplus
}
}
#endif

460
lib/linalg/dlasd6.cpp
View File

@ -1,396 +1,35 @@
/* fortran/dlasd6.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__0 = 0;
static doublereal c_b7 = 1.;
static integer c__1 = 1;
static integer c_n1 = -1;
/* > \brief \b DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller o
nes by appending a row. Used by sbdsdc. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASD6 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasd6.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasd6.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasd6.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, */
/* IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, */
/* LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, */
/* IWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, */
/* $ NR, SQRE */
/* DOUBLE PRECISION ALPHA, BETA, C, S */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), */
/* $ PERM( * ) */
/* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), */
/* $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), */
/* $ VF( * ), VL( * ), WORK( * ), Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASD6 computes the SVD of an updated upper bidiagonal matrix B */
/* > obtained by merging two smaller ones by appending a row. This */
/* > routine is used only for the problem which requires all singular */
/* > values and optionally singular vector matrices in factored form. */
/* > B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. */
/* > A related subroutine, DLASD1, handles the case in which all singular */
/* > values and singular vectors of the bidiagonal matrix are desired. */
/* > */
/* > DLASD6 computes the SVD as follows: */
/* > */
/* > ( D1(in) 0 0 0 ) */
/* > B = U(in) * ( Z1**T a Z2**T b ) * VT(in) */
/* > ( 0 0 D2(in) 0 ) */
/* > */
/* > = U(out) * ( D(out) 0) * VT(out) */
/* > */
/* > where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M */
/* > with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */
/* > elsewhere; and the entry b is empty if SQRE = 0. */
/* > */
/* > The singular values of B can be computed using D1, D2, the first */
/* > components of all the right singular vectors of the lower block, and */
/* > the last components of all the right singular vectors of the upper */
/* > block. These components are stored and updated in VF and VL, */
/* > respectively, in DLASD6. Hence U and VT are not explicitly */
/* > referenced. */
/* > */
/* > The singular values are stored in D. The algorithm consists of two */
/* > stages: */
/* > */
/* > The first stage consists of deflating the size of the problem */
/* > when there are multiple singular values or if there is a zero */
/* > in the Z vector. For each such occurrence the dimension of the */
/* > secular equation problem is reduced by one. This stage is */
/* > performed by the routine DLASD7. */
/* > */
/* > The second stage consists of calculating the updated */
/* > singular values. This is done by finding the roots of the */
/* > secular equation via the routine DLASD4 (as called by DLASD8). */
/* > This routine also updates VF and VL and computes the distances */
/* > between the updated singular values and the old singular */
/* > values. */
/* > */
/* > DLASD6 is called from DLASDA. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > Specifies whether singular vectors are to be computed in */
/* > factored form: */
/* > = 0: Compute singular values only. */
/* > = 1: Compute singular vectors in factored form as well. */
/* > \endverbatim */
/* > */
/* > \param[in] NL */
/* > \verbatim */
/* > NL is INTEGER */
/* > The row dimension of the upper block. NL >= 1. */
/* > \endverbatim */
/* > */
/* > \param[in] NR */
/* > \verbatim */
/* > NR is INTEGER */
/* > The row dimension of the lower block. NR >= 1. */
/* > \endverbatim */
/* > */
/* > \param[in] SQRE */
/* > \verbatim */
/* > SQRE is INTEGER */
/* > = 0: the lower block is an NR-by-NR square matrix. */
/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
/* > */
/* > The bidiagonal matrix has row dimension N = NL + NR + 1, */
/* > and column dimension M = N + SQRE. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension ( NL+NR+1 ). */
/* > On entry D(1:NL,1:NL) contains the singular values of the */
/* > upper block, and D(NL+2:N) contains the singular values */
/* > of the lower block. On exit D(1:N) contains the singular */
/* > values of the modified matrix. */
/* > \endverbatim */
/* > */
/* > \param[in,out] VF */
/* > \verbatim */
/* > VF is DOUBLE PRECISION array, dimension ( M ) */
/* > On entry, VF(1:NL+1) contains the first components of all */
/* > right singular vectors of the upper block; and VF(NL+2:M) */
/* > contains the first components of all right singular vectors */
/* > of the lower block. On exit, VF contains the first components */
/* > of all right singular vectors of the bidiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[in,out] VL */
/* > \verbatim */
/* > VL is DOUBLE PRECISION array, dimension ( M ) */
/* > On entry, VL(1:NL+1) contains the last components of all */
/* > right singular vectors of the upper block; and VL(NL+2:M) */
/* > contains the last components of all right singular vectors of */
/* > the lower block. On exit, VL contains the last components of */
/* > all right singular vectors of the bidiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[in,out] ALPHA */
/* > \verbatim */
/* > ALPHA is DOUBLE PRECISION */
/* > Contains the diagonal element associated with the added row. */
/* > \endverbatim */
/* > */
/* > \param[in,out] BETA */
/* > \verbatim */
/* > BETA is DOUBLE PRECISION */
/* > Contains the off-diagonal element associated with the added */
/* > row. */
/* > \endverbatim */
/* > */
/* > \param[in,out] IDXQ */
/* > \verbatim */
/* > IDXQ is INTEGER array, dimension ( N ) */
/* > This contains the permutation which will reintegrate the */
/* > subproblem just solved back into sorted order, i.e. */
/* > D( IDXQ( I = 1, N ) ) will be in ascending order. */
/* > \endverbatim */
/* > */
/* > \param[out] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, dimension ( N ) */
/* > The permutations (from deflation and sorting) to be applied */
/* > to each block. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER */
/* > The number of Givens rotations which took place in this */
/* > subproblem. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) */
/* > Each pair of numbers indicates a pair of columns to take place */
/* > in a Givens rotation. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGCOL */
/* > \verbatim */
/* > LDGCOL is INTEGER */
/* > leading dimension of GIVCOL, must be at least N. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* > Each number indicates the C or S value to be used in the */
/* > corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGNUM */
/* > \verbatim */
/* > LDGNUM is INTEGER */
/* > The leading dimension of GIVNUM and POLES, must be at least N. */
/* > \endverbatim */
/* > */
/* > \param[out] POLES */
/* > \verbatim */
/* > POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* > On exit, POLES(1,*) is an array containing the new singular */
/* > values obtained from solving the secular equation, and */
/* > POLES(2,*) is an array containing the poles in the secular */
/* > equation. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[out] DIFL */
/* > \verbatim */
/* > DIFL is DOUBLE PRECISION array, dimension ( N ) */
/* > On exit, DIFL(I) is the distance between I-th updated */
/* > (undeflated) singular value and the I-th (undeflated) old */
/* > singular value. */
/* > \endverbatim */
/* > */
/* > \param[out] DIFR */
/* > \verbatim */
/* > DIFR is DOUBLE PRECISION array, */
/* > dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
/* > dimension ( K ) if ICOMPQ = 0. */
/* > On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
/* > defined and will not be referenced. */
/* > */
/* > If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
/* > normalizing factors for the right singular vector matrix. */
/* > */
/* > See DLASD8 for details on DIFL and DIFR. */
/* > \endverbatim */
/* > */
/* > \param[out] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( M ) */
/* > The first elements of this array contain the components */
/* > of the deflation-adjusted updating row vector. */
/* > \endverbatim */
/* > */
/* > \param[out] K */
/* > \verbatim */
/* > K is INTEGER */
/* > Contains the dimension of the non-deflated matrix, */
/* > This is the order of the related secular equation. 1 <= K <=N. */
/* > \endverbatim */
/* > */
/* > \param[out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION */
/* > C contains garbage if SQRE =0 and the C-value of a Givens */
/* > rotation related to the right null space if SQRE = 1. */
/* > \endverbatim */
/* > */
/* > \param[out] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION */
/* > S contains garbage if SQRE =0 and the S-value of a Givens */
/* > rotation related to the right null space if SQRE = 1. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension ( 4 * M ) */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension ( 3 * N ) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: if INFO = 1, a singular value did not converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Huan Ren, Computer Science Division, University of */
/* > California at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr,
integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl,
doublereal *alpha, doublereal *beta, integer *idxq, integer *perm,
integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *
difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s,
doublereal *work, integer *iwork, integer *info)
int dlasd6_(integer *icompq, integer *nl, integer *nr, integer *sqre, doublereal *d__,
doublereal *vf, doublereal *vl, doublereal *alpha, doublereal *beta, integer *idxq,
integer *perm, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *difr, doublereal *z__,
integer *k, doublereal *c__, doublereal *s, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, i__1;
integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlasd7_(integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *), dlasd8_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlamrg_(integer *, integer *,
doublereal *, integer *, integer *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dlasd7_(integer *, integer *, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *),
dlasd8_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *);
integer isigma;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
doublereal orgnrm;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--vf;
--vl;
@ -410,12 +49,9 @@ f"> */
--z__;
--work;
--iwork;
/* Function Body */
*info = 0;
n = *nl + *nr + 1;
m = n + *sqre;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*nl < 1) {
@ -434,81 +70,43 @@ f"> */
xerbla_((char *)"DLASD6", &i__1, (ftnlen)6);
return 0;
}
/* The following values are for bookkeeping purposes only. They are */
/* integer pointers which indicate the portion of the workspace */
/* used by a particular array in DLASD7 and DLASD8. */
isigma = 1;
iw = isigma + n;
ivfw = iw + m;
ivlw = ivfw + m;
idx = 1;
idxc = idx + n;
idxp = idxc + n;
/* Scale. */
/* Computing MAX */
d__1 = abs(*alpha), d__2 = abs(*beta);
orgnrm = max(d__1,d__2);
orgnrm = max(d__1, d__2);
d__[*nl + 1] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
orgnrm = (d__1 = d__[i__], abs(d__1));
}
/* L10: */
}
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info, (
ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info, (ftnlen)1);
*alpha /= orgnrm;
*beta /= orgnrm;
/* Sort and Deflate singular values. */
dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], &
work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], &
iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[
givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s,
info);
/* 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],
ldgnum, &work[isigma], &work[iw], info);
/* Report the possible convergence failure. */
dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], &work[ivfw], &vl[1],
&work[ivlw], alpha, beta, &work[isigma], &iwork[idx], &iwork[idxp], &idxq[1], &perm[1],
givptr, &givcol[givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, info);
dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], ldgnum, &work[isigma],
&work[iw], info);
if (*info != 0) {
return 0;
}
/* Save the poles if ICOMPQ = 1. */
if (*icompq == 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);
}
/* Unscale. */
dlascl_((char *)"G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info, (
ftnlen)1);
/* Prepare the IDXQ sorting permutation. */
dlascl_((char *)"G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info, (ftnlen)1);
n1 = *k;
n2 = n - *k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
return 0;
/* End of DLASD6 */
} /* dlasd6_ */
}
#ifdef __cplusplus
}
}
#endif

459
lib/linalg/dlasd7.cpp
View File

@ -1,362 +1,31 @@
/* fortran/dlasd7.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \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. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASD7 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasd7.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasd7.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasd7.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, */
/* VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, */
/* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, */
/* C, S, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, */
/* $ NR, SQRE */
/* DOUBLE PRECISION ALPHA, BETA, C, S */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), */
/* $ IDXQ( * ), PERM( * ) */
/* DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), */
/* $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), */
/* $ ZW( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASD7 merges the two sets of singular values together into a single */
/* > sorted set. Then it tries to deflate the size of the problem. There */
/* > are two ways in which deflation can occur: when two or more singular */
/* > values are close together or if there is a tiny entry in the Z */
/* > vector. For each such occurrence the order of the related */
/* > secular equation problem is reduced by one. */
/* > */
/* > DLASD7 is called from DLASD6. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > Specifies whether singular vectors are to be computed */
/* > in compact form, as follows: */
/* > = 0: Compute singular values only. */
/* > = 1: Compute singular vectors of upper */
/* > bidiagonal matrix in compact form. */
/* > \endverbatim */
/* > */
/* > \param[in] NL */
/* > \verbatim */
/* > NL is INTEGER */
/* > The row dimension of the upper block. NL >= 1. */
/* > \endverbatim */
/* > */
/* > \param[in] NR */
/* > \verbatim */
/* > NR is INTEGER */
/* > The row dimension of the lower block. NR >= 1. */
/* > \endverbatim */
/* > */
/* > \param[in] SQRE */
/* > \verbatim */
/* > SQRE is INTEGER */
/* > = 0: the lower block is an NR-by-NR square matrix. */
/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
/* > */
/* > The bidiagonal matrix has */
/* > N = NL + NR + 1 rows and */
/* > M = N + SQRE >= N columns. */
/* > \endverbatim */
/* > */
/* > \param[out] K */
/* > \verbatim */
/* > K is INTEGER */
/* > Contains the dimension of the non-deflated matrix, this is */
/* > the order of the related secular equation. 1 <= K <=N. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension ( N ) */
/* > On entry D contains the singular values of the two submatrices */
/* > to be combined. On exit D contains the trailing (N-K) updated */
/* > singular values (those which were deflated) sorted into */
/* > increasing order. */
/* > \endverbatim */
/* > */
/* > \param[out] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( M ) */
/* > On exit Z contains the updating row vector in the secular */
/* > equation. */
/* > \endverbatim */
/* > */
/* > \param[out] ZW */
/* > \verbatim */
/* > ZW is DOUBLE PRECISION array, dimension ( M ) */
/* > Workspace for Z. */
/* > \endverbatim */
/* > */
/* > \param[in,out] VF */
/* > \verbatim */
/* > VF is DOUBLE PRECISION array, dimension ( M ) */
/* > On entry, VF(1:NL+1) contains the first components of all */
/* > right singular vectors of the upper block; and VF(NL+2:M) */
/* > contains the first components of all right singular vectors */
/* > of the lower block. On exit, VF contains the first components */
/* > of all right singular vectors of the bidiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] VFW */
/* > \verbatim */
/* > VFW is DOUBLE PRECISION array, dimension ( M ) */
/* > Workspace for VF. */
/* > \endverbatim */
/* > */
/* > \param[in,out] VL */
/* > \verbatim */
/* > VL is DOUBLE PRECISION array, dimension ( M ) */
/* > On entry, VL(1:NL+1) contains the last components of all */
/* > right singular vectors of the upper block; and VL(NL+2:M) */
/* > contains the last components of all right singular vectors */
/* > of the lower block. On exit, VL contains the last components */
/* > of all right singular vectors of the bidiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] VLW */
/* > \verbatim */
/* > VLW is DOUBLE PRECISION array, dimension ( M ) */
/* > Workspace for VL. */
/* > \endverbatim */
/* > */
/* > \param[in] ALPHA */
/* > \verbatim */
/* > ALPHA is DOUBLE PRECISION */
/* > Contains the diagonal element associated with the added row. */
/* > \endverbatim */
/* > */
/* > \param[in] BETA */
/* > \verbatim */
/* > BETA is DOUBLE PRECISION */
/* > Contains the off-diagonal element associated with the added */
/* > row. */
/* > \endverbatim */
/* > */
/* > \param[out] DSIGMA */
/* > \verbatim */
/* > DSIGMA is DOUBLE PRECISION array, dimension ( N ) */
/* > Contains a copy of the diagonal elements (K-1 singular values */
/* > and one zero) in the secular equation. */
/* > \endverbatim */
/* > */
/* > \param[out] IDX */
/* > \verbatim */
/* > IDX is INTEGER array, dimension ( N ) */
/* > This will contain the permutation used to sort the contents of */
/* > D into ascending order. */
/* > \endverbatim */
/* > */
/* > \param[out] IDXP */
/* > \verbatim */
/* > IDXP is INTEGER array, dimension ( N ) */
/* > This will contain the permutation used to place deflated */
/* > values of D at the end of the array. On output IDXP(2:K) */
/* > points to the nondeflated D-values and IDXP(K+1:N) */
/* > points to the deflated singular values. */
/* > \endverbatim */
/* > */
/* > \param[in] IDXQ */
/* > \verbatim */
/* > IDXQ is INTEGER array, dimension ( N ) */
/* > This contains the permutation which separately sorts the two */
/* > sub-problems in D into ascending order. Note that entries in */
/* > the first half of this permutation must first be moved one */
/* > position backward; and entries in the second half */
/* > must first have NL+1 added to their values. */
/* > \endverbatim */
/* > */
/* > \param[out] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, dimension ( N ) */
/* > The permutations (from deflation and sorting) to be applied */
/* > to each singular block. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER */
/* > The number of Givens rotations which took place in this */
/* > subproblem. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) */
/* > Each pair of numbers indicates a pair of columns to take place */
/* > in a Givens rotation. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGCOL */
/* > \verbatim */
/* > LDGCOL is INTEGER */
/* > The leading dimension of GIVCOL, must be at least N. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* > Each number indicates the C or S value to be used in the */
/* > corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGNUM */
/* > \verbatim */
/* > LDGNUM is INTEGER */
/* > The leading dimension of GIVNUM, must be at least N. */
/* > \endverbatim */
/* > */
/* > \param[out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION */
/* > C contains garbage if SQRE =0 and the C-value of a Givens */
/* > rotation related to the right null space if SQRE = 1. */
/* > \endverbatim */
/* > */
/* > \param[out] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION */
/* > S contains garbage if SQRE =0 and the S-value of a Givens */
/* > rotation related to the right null space if SQRE = 1. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Huan Ren, Computer Science Division, University of */
/* > California at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *k, doublereal *d__, doublereal *z__,
doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl,
doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *
dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm,
integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
integer *ldgnum, doublereal *c__, doublereal *s, integer *info)
int dlasd7_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d__,
doublereal *z__, doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl,
doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *dsigma, integer *idx,
integer *idxp, integer *idxq, integer *perm, integer *givptr, integer *givcol,
integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *c__, doublereal *s,
integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer i__, j, m, n, k2;
doublereal z1;
integer jp;
doublereal eps, tau, tol;
integer nlp1, nlp2, idxi, idxj;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer idxjp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer jprev;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *,
ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen);
extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *),
xerbla_(char *, integer *, ftnlen);
doublereal hlftol;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
--zw;
@ -375,12 +44,9 @@ f"> */
givnum_dim1 = *ldgnum;
givnum_offset = 1 + givnum_dim1;
givnum -= givnum_offset;
/* Function Body */
*info = 0;
n = *nl + *nr + 1;
m = n + *sqre;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*nl < 1) {
@ -399,16 +65,11 @@ f"> */
xerbla_((char *)"DLASD7", &i__1, (ftnlen)6);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
if (*icompq == 1) {
*givptr = 0;
}
/* Generate the first part of the vector Z and move the singular */
/* values in the first part of D one position backward. */
z1 = *alpha * vl[nlp1];
vl[nlp1] = 0.;
tau = vf[nlp1];
@ -418,40 +79,25 @@ f"> */
vf[i__ + 1] = vf[i__];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */
}
vf[1] = tau;
/* Generate the second part of the vector Z. */
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
z__[i__] = *beta * vf[i__];
vf[i__] = 0.;
/* L20: */
}
/* Sort the singular values into increasing order */
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
idxq[i__] += nlp1;
/* L30: */
}
/* DSIGMA, IDXC, IDXC, and ZW are used as storage space. */
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dsigma[i__] = d__[idxq[i__]];
zw[i__] = z__[idxq[i__]];
vfw[i__] = vf[idxq[i__]];
vlw[i__] = vl[idxq[i__]];
/* L40: */
}
dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
idxi = idx[i__] + 1;
@ -459,46 +105,17 @@ f"> */
z__[i__] = zw[idxi];
vf[i__] = vfw[idxi];
vl[i__] = vlw[idxi];
/* L50: */
}
/* Calculate the allowable deflation tolerance */
eps = dlamch_((char *)"Epsilon", (ftnlen)7);
/* Computing MAX */
d__1 = abs(*alpha), d__2 = abs(*beta);
tol = max(d__1,d__2);
/* Computing MAX */
tol = max(d__1, d__2);
d__2 = (d__1 = d__[n], abs(d__1));
tol = eps * 64. * max(d__2,tol);
/* There are 2 kinds of deflation -- first a value in the z-vector */
/* is small, second two (or more) singular values are very close */
/* together (their difference is small). */
/* If the value in the z-vector is small, we simply permute the */
/* array so that the corresponding singular value is moved to the */
/* end. */
/* If two values in the D-vector are close, we perform a two-sided */
/* rotation designed to make one of the corresponding z-vector */
/* entries zero, and then permute the array so that the deflated */
/* singular value is moved to the end. */
/* If there are multiple singular values then the problem deflates. */
/* Here the number of equal singular values are found. As each equal */
/* singular value is found, an elementary reflector is computed to */
/* rotate the corresponding singular subspace so that the */
/* corresponding components of Z are zero in this new basis. */
tol = eps * 64. * max(d__2, tol);
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2; j <= i__1; ++j) {
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
if (j == n) {
@ -508,7 +125,6 @@ f"> */
jprev = j;
goto L70;
}
/* L60: */
}
L70:
j = jprev;
@ -518,33 +134,17 @@ L80:
goto L90;
}
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
} else {
/* Check if singular values are close enough to allow deflation. */
if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
/* Deflation is possible. */
*s = z__[jprev];
*c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = dlapy2_(c__, s);
z__[j] = tau;
z__[jprev] = 0.;
*c__ /= tau;
*s = -(*s) / tau;
/* Record the appropriate Givens rotation */
if (*icompq == 1) {
++(*givptr);
idxjp = idxq[idx[jprev] + 1];
@ -575,27 +175,17 @@ L80:
}
goto L80;
L90:
/* Record the last singular value. */
++(*k);
zw[*k] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L100:
/* Sort the singular values into DSIGMA. The singular values which */
/* were not deflated go into the first K slots of DSIGMA, except */
/* that DSIGMA(1) is treated separately. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
dsigma[j] = d__[jp];
vfw[j] = vf[jp];
vlw[j] = vl[jp];
/* L110: */
}
if (*icompq == 1) {
i__1 = n;
@ -605,19 +195,10 @@ L100:
if (perm[j] <= nlp1) {
--perm[j];
}
/* L120: */
}
}
/* The deflated singular values go back into the last N - K slots of */
/* D. */
i__1 = n - *k;
dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
/* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and */
/* VL(M). */
dsigma[1] = 0.;
hlftol = tol / 2.;
if (abs(dsigma[2]) <= hlftol) {
@ -642,22 +223,14 @@ L100:
z__[1] = z1;
}
}
/* Restore Z, VF, and VL. */
i__1 = *k - 1;
dcopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1);
i__1 = n - 1;
dcopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1);
i__1 = n - 1;
dcopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1);
return 0;
/* End of DLASD7 */
} /* dlasd7_ */
}
#ifdef __cplusplus
}
}
#endif

329
lib/linalg/dlasd8.cpp
View File

@ -1,254 +1,35 @@
/* fortran/dlasd8.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static doublereal c_b8 = 1.;
/* > \brief \b DLASD8 finds the square roots of the roots of the secular equation, and stores, for each elemen
t in D, the distance to its two nearest poles. Used by sbdsdc. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASD8 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasd8.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasd8.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasd8.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, */
/* DSIGMA, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER ICOMPQ, INFO, K, LDDIFR */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), */
/* $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), */
/* $ Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASD8 finds the square roots of the roots of the secular equation, */
/* > as defined by the values in DSIGMA and Z. It makes the appropriate */
/* > calls to DLASD4, and stores, for each element in D, the distance */
/* > to its two nearest poles (elements in DSIGMA). It also updates */
/* > the arrays VF and VL, the first and last components of all the */
/* > right singular vectors of the original bidiagonal matrix. */
/* > */
/* > DLASD8 is called from DLASD6. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > Specifies whether singular vectors are to be computed in */
/* > factored form in the calling routine: */
/* > = 0: Compute singular values only. */
/* > = 1: Compute singular vectors in factored form as well. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of terms in the rational function to be solved */
/* > by DLASD4. K >= 1. */
/* > \endverbatim */
/* > */
/* > \param[out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension ( K ) */
/* > On output, D contains the updated singular values. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( K ) */
/* > On entry, the first K elements of this array contain the */
/* > components of the deflation-adjusted updating row vector. */
/* > On exit, Z is updated. */
/* > \endverbatim */
/* > */
/* > \param[in,out] VF */
/* > \verbatim */
/* > VF is DOUBLE PRECISION array, dimension ( K ) */
/* > On entry, VF contains information passed through DBEDE8. */
/* > On exit, VF contains the first K components of the first */
/* > components of all right singular vectors of the bidiagonal */
/* > matrix. */
/* > \endverbatim */
/* > */
/* > \param[in,out] VL */
/* > \verbatim */
/* > VL is DOUBLE PRECISION array, dimension ( K ) */
/* > On entry, VL contains information passed through DBEDE8. */
/* > On exit, VL contains the first K components of the last */
/* > components of all right singular vectors of the bidiagonal */
/* > matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] DIFL */
/* > \verbatim */
/* > DIFL is DOUBLE PRECISION array, dimension ( K ) */
/* > On exit, DIFL(I) = D(I) - DSIGMA(I). */
/* > \endverbatim */
/* > */
/* > \param[out] DIFR */
/* > \verbatim */
/* > DIFR is DOUBLE PRECISION array, */
/* > dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
/* > dimension ( K ) if ICOMPQ = 0. */
/* > On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
/* > defined and will not be referenced. */
/* > */
/* > If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
/* > normalizing factors for the right singular vector matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] LDDIFR */
/* > \verbatim */
/* > LDDIFR is INTEGER */
/* > The leading dimension of DIFR, must be at least K. */
/* > \endverbatim */
/* > */
/* > \param[in,out] DSIGMA */
/* > \verbatim */
/* > DSIGMA is DOUBLE PRECISION array, dimension ( K ) */
/* > On entry, the first K elements of this array contain the old */
/* > roots of the deflated updating problem. These are the poles */
/* > of the secular equation. */
/* > On exit, the elements of DSIGMA may be very slightly altered */
/* > in value. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (3*K) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: if INFO = 1, a singular value did not converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Huan Ren, Computer Science Division, University of */
/* > California at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
work, integer *info)
int dlasd8_(integer *icompq, integer *k, doublereal *d__, doublereal *z__, doublereal *vf,
doublereal *vl, doublereal *difl, doublereal *difr, integer *lddifr, doublereal *dsigma,
doublereal *work, integer *info)
{
/* System generated locals */
integer difr_dim1, difr_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j;
doublereal dj, rho;
integer iwk1, iwk2, iwk3;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
integer iwk2i, iwk3i;
doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern int dlasd4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
doublereal dsigjp;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
--vf;
@ -259,10 +40,7 @@ f"> */
difr -= difr_offset;
--dsigma;
--work;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*k < 1) {
@ -275,9 +53,6 @@ f"> */
xerbla_((char *)"DLASD8", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*k == 1) {
d__[1] = abs(z__[1]);
difl[1] = d__[1];
@ -287,59 +62,22 @@ f"> */
}
return 0;
}
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DSIGMA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L10: */
}
/* Book keeping. */
iwk1 = 1;
iwk2 = iwk1 + *k;
iwk3 = iwk2 + *k;
iwk2i = iwk2 - 1;
iwk3i = iwk3 - 1;
/* Normalize Z. */
rho = dnrm2_(k, &z__[1], &c__1);
dlascl_((char *)"G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info, (
ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info, (ftnlen)1);
rho *= rho;
/* Initialize WORK(IWK3). */
dlaset_((char *)"A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k, (ftnlen)1);
/* Compute the updated singular values, the arrays DIFL, DIFR, */
/* and the updated Z. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
iwk2], info);
/* If the root finder fails, report the convergence failure. */
dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[iwk2], info);
if (*info != 0) {
return 0;
}
@ -348,32 +86,20 @@ f"> */
difr[j + difr_dim1] = -work[j + 1];
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L20: */
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + i__] /
(dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]);
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L30: */
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + i__] /
(dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]);
}
/* L40: */
}
/* Compute updated Z. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1)));
z__[i__] = d_lmp_sign(&d__2, &z__[i__]);
/* L50: */
}
/* Update VF and VL. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
@ -386,15 +112,11 @@ f"> */
work[j] = -z__[j] / diflj / (dsigma[j] + dj);
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (
dsigma[i__] + dj);
/* L60: */
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (dsigma[i__] + dj);
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) /
(dsigma[i__] + dj);
/* L70: */
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) / (dsigma[i__] + dj);
}
temp = dnrm2_(k, &work[1], &c__1);
work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
@ -402,18 +124,11 @@ f"> */
if (*icompq == 1) {
difr[j + (difr_dim1 << 1)] = temp;
}
/* L80: */
}
dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
return 0;
/* End of DLASD8 */
} /* dlasd8_ */
}
#ifdef __cplusplus
}
}
#endif

498
lib/linalg/dlasda.cpp
View File

@ -1,367 +1,44 @@
/* fortran/dlasda.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__0 = 0;
static doublereal c_b11 = 0.;
static doublereal c_b12 = 1.;
static integer c__1 = 1;
static integer c__2 = 2;
/* > \brief \b DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with d
iagonal d and off-diagonal e. Used by sbdsdc. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASDA + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasda.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasda.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasda.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, */
/* DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, */
/* PERM, GIVNUM, C, S, WORK, IWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE */
/* .. */
/* .. Array Arguments .. */
/* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), */
/* $ K( * ), PERM( LDGCOL, * ) */
/* DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), */
/* $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), */
/* $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), */
/* $ Z( LDU, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > Using a divide and conquer approach, DLASDA computes the singular */
/* > value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */
/* > B with diagonal D and offdiagonal E, where M = N + SQRE. The */
/* > algorithm computes the singular values in the SVD B = U * S * VT. */
/* > The orthogonal matrices U and VT are optionally computed in */
/* > compact form. */
/* > */
/* > A related subroutine, DLASD0, computes the singular values and */
/* > the singular vectors in explicit form. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ICOMPQ */
/* > \verbatim */
/* > ICOMPQ is INTEGER */
/* > Specifies whether singular vectors are to be computed */
/* > in compact form, as follows */
/* > = 0: Compute singular values only. */
/* > = 1: Compute singular vectors of upper bidiagonal */
/* > matrix in compact form. */
/* > \endverbatim */
/* > */
/* > \param[in] SMLSIZ */
/* > \verbatim */
/* > SMLSIZ is INTEGER */
/* > The maximum size of the subproblems at the bottom of the */
/* > computation tree. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The row dimension of the upper bidiagonal matrix. This is */
/* > also the dimension of the main diagonal array D. */
/* > \endverbatim */
/* > */
/* > \param[in] SQRE */
/* > \verbatim */
/* > SQRE is INTEGER */
/* > Specifies the column dimension of the bidiagonal matrix. */
/* > = 0: The bidiagonal matrix has column dimension M = N; */
/* > = 1: The bidiagonal matrix has column dimension M = N + 1. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension ( N ) */
/* > On entry D contains the main diagonal of the bidiagonal */
/* > matrix. On exit D, if INFO = 0, contains its singular values. */
/* > \endverbatim */
/* > */
/* > \param[in] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension ( M-1 ) */
/* > Contains the subdiagonal entries of the bidiagonal matrix. */
/* > On exit, E has been destroyed. */
/* > \endverbatim */
/* > */
/* > \param[out] U */
/* > \verbatim */
/* > U is DOUBLE PRECISION array, */
/* > dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */
/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left */
/* > singular vector matrices of all subproblems at the bottom */
/* > level. */
/* > \endverbatim */
/* > */
/* > \param[in] LDU */
/* > \verbatim */
/* > LDU is INTEGER, LDU = > N. */
/* > The leading dimension of arrays U, VT, DIFL, DIFR, POLES, */
/* > GIVNUM, and Z. */
/* > \endverbatim */
/* > */
/* > \param[out] VT */
/* > \verbatim */
/* > VT is DOUBLE PRECISION array, */
/* > dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */
/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right */
/* > singular vector matrices of all subproblems at the bottom */
/* > level. */
/* > \endverbatim */
/* > */
/* > \param[out] K */
/* > \verbatim */
/* > K is INTEGER array, */
/* > dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */
/* > If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */
/* > secular equation on the computation tree. */
/* > \endverbatim */
/* > */
/* > \param[out] DIFL */
/* > \verbatim */
/* > DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ), */
/* > where NLVL = floor(log_2 (N/SMLSIZ))). */
/* > \endverbatim */
/* > */
/* > \param[out] DIFR */
/* > \verbatim */
/* > DIFR is DOUBLE PRECISION array, */
/* > dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */
/* > dimension ( N ) if ICOMPQ = 0. */
/* > If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */
/* > record distances between singular values on the I-th */
/* > level and singular values on the (I -1)-th level, and */
/* > DIFR(1:N, 2 * I ) contains the normalizing factors for */
/* > the right singular vector matrix. See DLASD8 for details. */
/* > \endverbatim */
/* > */
/* > \param[out] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, */
/* > dimension ( LDU, NLVL ) if ICOMPQ = 1 and */
/* > dimension ( N ) if ICOMPQ = 0. */
/* > The first K elements of Z(1, I) contain the components of */
/* > the deflation-adjusted updating row vector for subproblems */
/* > on the I-th level. */
/* > \endverbatim */
/* > */
/* > \param[out] POLES */
/* > \verbatim */
/* > POLES is DOUBLE PRECISION array, */
/* > dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */
/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */
/* > POLES(1, 2*I) contain the new and old singular values */
/* > involved in the secular equations on the I-th level. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVPTR */
/* > \verbatim */
/* > GIVPTR is INTEGER array, */
/* > dimension ( N ) if ICOMPQ = 1, and not referenced if */
/* > ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */
/* > the number of Givens rotations performed on the I-th */
/* > problem on the computation tree. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVCOL */
/* > \verbatim */
/* > GIVCOL is INTEGER array, */
/* > dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */
/* > referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
/* > GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations */
/* > of Givens rotations performed on the I-th level on the */
/* > computation tree. */
/* > \endverbatim */
/* > */
/* > \param[in] LDGCOL */
/* > \verbatim */
/* > LDGCOL is INTEGER, LDGCOL = > N. */
/* > The leading dimension of arrays GIVCOL and PERM. */
/* > \endverbatim */
/* > */
/* > \param[out] PERM */
/* > \verbatim */
/* > PERM is INTEGER array, */
/* > dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced */
/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */
/* > permutations done on the I-th level of the computation tree. */
/* > \endverbatim */
/* > */
/* > \param[out] GIVNUM */
/* > \verbatim */
/* > GIVNUM is DOUBLE PRECISION array, */
/* > dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */
/* > referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
/* > GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */
/* > values of Givens rotations performed on the I-th level on */
/* > the computation tree. */
/* > \endverbatim */
/* > */
/* > \param[out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, */
/* > dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */
/* > If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */
/* > C( I ) contains the C-value of a Givens rotation related to */
/* > the right null space of the I-th subproblem. */
/* > \endverbatim */
/* > */
/* > \param[out] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION array, dimension ( N ) if */
/* > ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */
/* > and the I-th subproblem is not square, on exit, S( I ) */
/* > contains the S-value of a Givens rotation related to */
/* > the right null space of the I-th subproblem. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension */
/* > (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */
/* > \endverbatim */
/* > */
/* > \param[out] IWORK */
/* > \verbatim */
/* > IWORK is INTEGER array, dimension (7*N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit. */
/* > < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > > 0: if INFO = 1, a singular value did not converge */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Huan Ren, Computer Science Division, University of */
/* > California at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n,
integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer
*ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr,
doublereal *z__, doublereal *poles, integer *givptr, integer *givcol,
integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__,
doublereal *s, doublereal *work, integer *iwork, integer *info)
int dlasda_(integer *icompq, integer *smlsiz, integer *n, integer *sqre, doublereal *d__,
doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *k,
doublereal *difl, doublereal *difr, doublereal *z__, doublereal *poles, integer *givptr,
integer *givcol, integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__,
doublereal *s, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
z_dim1, z_offset, i__1, i__2;
/* Builtin functions */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, difl_offset, difr_dim1,
difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, u_dim1, u_offset,
vt_dim1, vt_offset, z_dim1, z_offset, i__1, i__2;
integer pow_lmp_ii(integer *, integer *);
/* Local variables */
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;
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;
doublereal beta;
integer idxq, nlvl;
doublereal alpha;
integer inode, ndiml, ndimr, idxqi, itemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer sqrei;
extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
extern int dlasd6_(integer *, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
integer nwork1, nwork2;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, ftnlen), dlasdt_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlaset_(
char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen), xerbla_(char *, integer *,
ftnlen);
extern int dlasdq_(char *, integer *, integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen),
dlasdt_(integer *, integer *, integer *, integer *, integer *, integer *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
integer smlszp;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
givnum_dim1 = *ldu;
@ -397,10 +74,7 @@ f"> */
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*smlsiz < 3) {
@ -419,57 +93,33 @@ f"> */
xerbla_((char *)"DLASDA", &i__1, (ftnlen)6);
return 0;
}
m = *n + *sqre;
/* If the input matrix is too small, call DLASDQ to find the SVD. */
if (*n <= *smlsiz) {
if (*icompq == 0) {
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, &
work[1], info, (ftnlen)1);
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, &work[1], info, (ftnlen)1);
} else {
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],
info, (ftnlen)1);
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], info, (ftnlen)1);
}
return 0;
}
/* Book-keeping and set up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
ncc = 0;
nru = 0;
smlszp = *smlsiz + 1;
vf = 1;
vl = vf + m;
nwork1 = vl + m;
nwork2 = nwork1 + smlszp * smlszp;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* for the nodes on bottom level of the tree, solve */
/* their subproblems by DLASDQ. */
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], smlsiz);
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node */
/* NL : number of rows of left subproblem */
/* NR : number of rows of right subproblem */
/* NLF: starting row of the left subproblem */
/* NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
@ -482,25 +132,19 @@ f"> */
vli = vl + nlf - 1;
sqrei = 1;
if (*icompq == 0) {
dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp,
(ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
&nl, &work[nwork2], info, (ftnlen)1);
dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &work[nwork1], &smlszp,
&work[nwork2], &nl, &work[nwork2], &nl, &work[nwork2], info, (ftnlen)1);
itemp = nwork1 + nl * smlszp;
dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_((char *)"A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu, (
ftnlen)1);
dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1],
ldu, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf +
u_dim1], ldu, &work[nwork1], info, (ftnlen)1);
dlaset_((char *)"A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu, (ftnlen)1);
dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], ldu, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[nlf + vt_dim1], ldu,
&u[nlf + u_dim1], ldu, &u[nlf + u_dim1], ldu, &work[nwork1], info, (ftnlen)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) {
return 0;
@ -508,7 +152,6 @@ f"> */
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L10: */
}
if (i__ == nd && *sqre == 0) {
sqrei = 0;
@ -520,25 +163,19 @@ f"> */
vli += nlp1;
nrp1 = nr + sqrei;
if (*icompq == 0) {
dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp,
(ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
&nr, &work[nwork2], info, (ftnlen)1);
dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &work[nwork1], &smlszp,
&work[nwork2], &nr, &work[nwork2], &nr, &work[nwork2], info, (ftnlen)1);
itemp = nwork1 + (nrp1 - 1) * smlszp;
dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_((char *)"A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu, (
ftnlen)1);
dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1],
ldu, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf +
u_dim1], ldu, &work[nwork1], info, (ftnlen)1);
dlaset_((char *)"A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu, (ftnlen)1);
dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], ldu, (ftnlen)1);
dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[nrf + vt_dim1], ldu,
&u[nrf + u_dim1], ldu, &u[nrf + u_dim1], ldu, &work[nwork1], info, (ftnlen)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) {
return 0;
@ -546,20 +183,11 @@ f"> */
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L20: */
}
/* L30: */
}
/* Now conquer each subproblem bottom-up. */
j = pow_lmp_ii(&c__2, &nlvl);
for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on */
/* the current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
@ -587,38 +215,28 @@ f"> */
alpha = d__[ic];
beta = e[ic];
if (*icompq == 0) {
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[
perm_offset], &givptr[1], &givcol[givcol_offset],
ldgcol, &givnum[givnum_offset], ldu, &poles[
poles_offset], &difl[difl_offset], &difr[difr_offset],
&z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
&iwork[iwk], info);
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &work[vli], &alpha, &beta,
&iwork[idxqi], &perm[perm_offset], &givptr[1], &givcol[givcol_offset],
ldgcol, &givnum[givnum_offset], ldu, &poles[poles_offset],
&difl[difl_offset], &difr[difr_offset], &z__[z_offset], &k[1], &c__[1],
&s[1], &work[nwork1], &iwork[iwk], info);
} else {
--j;
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf +
lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 *
givcol_dim1], ldgcol, &givnum[nlf + lvl2 *
givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], &
difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 *
difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j],
&s[j], &work[nwork1], &iwork[iwk], info);
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &work[vli], &alpha, &beta,
&iwork[idxqi], &perm[nlf + lvl * perm_dim1], &givptr[j],
&givcol[nlf + lvl2 * givcol_dim1], ldgcol,
&givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1],
&difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * difr_dim1],
&z__[nlf + lvl * z_dim1], &k[j], &c__[j], &s[j], &work[nwork1], &iwork[iwk],
info);
}
if (*info != 0) {
return 0;
}
/* L40: */
}
/* L50: */
}
return 0;
/* End of DLASDA */
} /* dlasda_ */
}
#ifdef __cplusplus
}
}
#endif

378
lib/linalg/dlasdq.cpp
View File

@ -1,293 +1,30 @@
/* fortran/dlasdq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by
sbdsdc. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASDQ + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasdq.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasdq.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasdq.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, */
/* U, LDU, C, LDC, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER UPLO */
/* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), */
/* $ VT( LDVT, * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASDQ computes the singular value decomposition (SVD) of a real */
/* > (upper or lower) bidiagonal matrix with diagonal D and offdiagonal */
/* > E, accumulating the transformations if desired. Letting B denote */
/* > the input bidiagonal matrix, the algorithm computes orthogonal */
/* > matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose */
/* > of P). The singular values S are overwritten on D. */
/* > */
/* > The input matrix U is changed to U * Q if desired. */
/* > The input matrix VT is changed to P**T * VT if desired. */
/* > The input matrix C is changed to Q**T * C if desired. */
/* > */
/* > See "Computing Small Singular Values of Bidiagonal Matrices With */
/* > Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
/* > LAPACK Working Note #3, for a detailed description of the algorithm. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] UPLO */
/* > \verbatim */
/* > UPLO is CHARACTER*1 */
/* > On entry, UPLO specifies whether the input bidiagonal matrix */
/* > is upper or lower bidiagonal, and whether it is square are */
/* > not. */
/* > UPLO = 'U' or 'u' B is upper bidiagonal. */
/* > UPLO = 'L' or 'l' B is lower bidiagonal. */
/* > \endverbatim */
/* > */
/* > \param[in] SQRE */
/* > \verbatim */
/* > SQRE is INTEGER */
/* > = 0: then the input matrix is N-by-N. */
/* > = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and */
/* > (N+1)-by-N if UPLU = 'L'. */
/* > */
/* > The bidiagonal matrix has */
/* > N = NL + NR + 1 rows and */
/* > M = N + SQRE >= N columns. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > On entry, N specifies the number of rows and columns */
/* > in the matrix. N must be at least 0. */
/* > \endverbatim */
/* > */
/* > \param[in] NCVT */
/* > \verbatim */
/* > NCVT is INTEGER */
/* > On entry, NCVT specifies the number of columns of */
/* > the matrix VT. NCVT must be at least 0. */
/* > \endverbatim */
/* > */
/* > \param[in] NRU */
/* > \verbatim */
/* > NRU is INTEGER */
/* > On entry, NRU specifies the number of rows of */
/* > the matrix U. NRU must be at least 0. */
/* > \endverbatim */
/* > */
/* > \param[in] NCC */
/* > \verbatim */
/* > NCC is INTEGER */
/* > On entry, NCC specifies the number of columns of */
/* > the matrix C. NCC must be at least 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, D contains the diagonal entries of the */
/* > bidiagonal matrix whose SVD is desired. On normal exit, */
/* > D contains the singular values in ascending order. */
/* > \endverbatim */
/* > */
/* > \param[in,out] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array. */
/* > dimension is (N-1) if SQRE = 0 and N if SQRE = 1. */
/* > On entry, the entries of E contain the offdiagonal entries */
/* > of the bidiagonal matrix whose SVD is desired. On normal */
/* > exit, E will contain 0. If the algorithm does not converge, */
/* > D and E will contain the diagonal and superdiagonal entries */
/* > of a bidiagonal matrix orthogonally equivalent to the one */
/* > given as input. */
/* > \endverbatim */
/* > */
/* > \param[in,out] VT */
/* > \verbatim */
/* > VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) */
/* > On entry, contains a matrix which on exit has been */
/* > premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 */
/* > and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). */
/* > \endverbatim */
/* > */
/* > \param[in] LDVT */
/* > \verbatim */
/* > LDVT is INTEGER */
/* > On entry, LDVT specifies the leading dimension of VT as */
/* > declared in the calling (sub) program. LDVT must be at */
/* > least 1. If NCVT is nonzero LDVT must also be at least N. */
/* > \endverbatim */
/* > */
/* > \param[in,out] U */
/* > \verbatim */
/* > U is DOUBLE PRECISION array, dimension (LDU, N) */
/* > On entry, contains a matrix which on exit has been */
/* > postmultiplied by Q, dimension NRU-by-N if SQRE = 0 */
/* > and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). */
/* > \endverbatim */
/* > */
/* > \param[in] LDU */
/* > \verbatim */
/* > LDU is INTEGER */
/* > On entry, LDU specifies the leading dimension of U as */
/* > declared in the calling (sub) program. LDU must be at */
/* > least max( 1, NRU ) . */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC, NCC) */
/* > On entry, contains an N-by-NCC matrix which on exit */
/* > has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 */
/* > and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > On entry, LDC specifies the leading dimension of C as */
/* > declared in the calling (sub) program. LDC must be at */
/* > least 1. If NCC is nonzero, LDC must also be at least N. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (4*N) */
/* > Workspace. Only referenced if one of NCVT, NRU, or NCC is */
/* > nonzero, and if N is at least 2. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > On exit, a value of 0 indicates a successful exit. */
/* > If INFO < 0, argument number -INFO is illegal. */
/* > If INFO > 0, the algorithm did not converge, and INFO */
/* > specifies how many superdiagonals did not converge. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Huan Ren, Computer Science Division, University of */
/* > California at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer *
ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e,
doublereal *vt, integer *ldvt, doublereal *u, integer *ldu,
doublereal *c__, integer *ldc, doublereal *work, integer *info,
ftnlen uplo_len)
int dlasdq_(char *uplo, integer *sqre, integer *n, integer *ncvt, integer *nru, integer *ncc,
doublereal *d__, doublereal *e, doublereal *vt, integer *ldvt, doublereal *u,
integer *ldu, doublereal *c__, integer *ldc, doublereal *work, integer *info,
ftnlen uplo_len)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
/* Local variables */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
integer i__, j;
doublereal r__, cs, sn;
integer np1, isub;
doublereal smin;
integer sqre1;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen, ftnlen), dswap_(integer *, doublereal *, integer *
, doublereal *, integer *);
extern int dlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
integer iuplo;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *, ftnlen), dbdsqr_(char *, integer *, integer *, integer
*, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen);
extern int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
xerbla_(char *, integer *, ftnlen),
dbdsqr_(char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, ftnlen);
logical rotate;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
@ -300,8 +37,6 @@ f"> */
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
@ -322,11 +57,11 @@ f"> */
*info = -5;
} else if (*ncc < 0) {
*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;
} else if (*ldu < max(1,*nru)) {
} else if (*ldu < max(1, *nru)) {
*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;
}
if (*info != 0) {
@ -337,16 +72,9 @@ f"> */
if (*n == 0) {
return 0;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
np1 = *n + 1;
sqre1 = *sqre;
/* If matrix non-square upper bidiagonal, rotate to be lower */
/* bidiagonal. The rotations are on the right. */
if (iuplo == 1 && sqre1 == 1) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
@ -358,7 +86,6 @@ f"> */
work[i__] = cs;
work[*n + i__] = sn;
}
/* L10: */
}
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__;
@ -369,18 +96,11 @@ f"> */
}
iuplo = 2;
sqre1 = 0;
/* Update singular vectors if desired. */
if (*ncvt > 0) {
dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncvt, &work[1], &work[np1], &vt[
vt_offset], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncvt, &work[1], &work[np1], &vt[vt_offset], ldvt, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
}
}
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left. */
if (iuplo == 2) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
@ -392,12 +112,7 @@ f"> */
work[i__] = cs;
work[*n + i__] = sn;
}
/* L20: */
}
/* If matrix (N+1)-by-N lower bidiagonal, one additional */
/* rotation is needed. */
if (sqre1 == 1) {
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__;
@ -406,43 +121,29 @@ f"> */
work[*n + *n] = sn;
}
}
/* Update singular vectors if desired. */
if (*nru > 0) {
if (sqre1 == 0) {
dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[np1], &u[
u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[np1], &u[u_offset], ldu, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
} else {
dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &np1, &work[1], &work[np1], &u[
u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &np1, &work[1], &work[np1], &u[u_offset], ldu, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
}
}
if (*ncc > 0) {
if (sqre1 == 0) {
dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[np1], &c__[
c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[np1], &c__[c_offset], ldc, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
} else {
dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncc, &work[1], &work[np1], &c__[
c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncc, &work[1], &work[np1], &c__[c_offset], ldc,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
}
}
}
/* Call DBDSQR to compute the SVD of the reduced real */
/* N-by-N upper bidiagonal matrix. */
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);
/* Sort the singular values into ascending order (insertion sort on */
/* singular values, but only one transposition per singular vector) */
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);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I). */
isub = i__;
smin = d__[i__];
i__2 = *n;
@ -451,36 +152,23 @@ f"> */
isub = j;
smin = d__[j];
}
/* L30: */
}
if (isub != i__) {
/* Swap singular values and vectors. */
d__[isub] = d__[i__];
d__[i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1],
ldvt);
dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], ldvt);
}
if (*nru > 0) {
dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1]
, &c__1);
dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1], &c__1);
}
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: */
}
return 0;
/* End of DLASDQ */
} /* dlasdq_ */
}
#ifdef __cplusplus
}
}
#endif

176
lib/linalg/dlasdt.cpp
View File

@ -1,172 +1,21 @@
/* fortran/dlasdt.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASDT + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasdt.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasdt.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasdt.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) */
/* .. Scalar Arguments .. */
/* INTEGER LVL, MSUB, N, ND */
/* .. */
/* .. Array Arguments .. */
/* INTEGER INODE( * ), NDIML( * ), NDIMR( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASDT creates a tree of subproblems for bidiagonal divide and */
/* > conquer. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > On entry, the number of diagonal elements of the */
/* > bidiagonal matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] LVL */
/* > \verbatim */
/* > LVL is INTEGER */
/* > On exit, the number of levels on the computation tree. */
/* > \endverbatim */
/* > */
/* > \param[out] ND */
/* > \verbatim */
/* > ND is INTEGER */
/* > On exit, the number of nodes on the tree. */
/* > \endverbatim */
/* > */
/* > \param[out] INODE */
/* > \verbatim */
/* > INODE is INTEGER array, dimension ( N ) */
/* > On exit, centers of subproblems. */
/* > \endverbatim */
/* > */
/* > \param[out] NDIML */
/* > \verbatim */
/* > NDIML is INTEGER array, dimension ( N ) */
/* > On exit, row dimensions of left children. */
/* > \endverbatim */
/* > */
/* > \param[out] NDIMR */
/* > \verbatim */
/* > NDIMR is INTEGER array, dimension ( N ) */
/* > On exit, row dimensions of right children. */
/* > \endverbatim */
/* > */
/* > \param[in] MSUB */
/* > \verbatim */
/* > MSUB is INTEGER */
/* > On entry, the maximum row dimension each subproblem at the */
/* > bottom of the tree can be of. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Contributors: */
/* ================== */
/* > */
/* > Ming Gu and Huan Ren, Computer Science Division, University of */
/* > California at Berkeley, USA */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer *
inode, integer *ndiml, integer *ndimr, integer *msub)
int dlasdt_(integer *n, integer *lvl, integer *nd, integer *inode, integer *ndiml, integer *ndimr,
integer *msub)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer i__, il, ir, maxn;
doublereal temp;
integer nlvl, llst, ncrnt;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Find the number of levels on the tree. */
/* Parameter adjustments */
--ndimr;
--ndiml;
--inode;
/* Function Body */
maxn = max(1,*n);
temp = log((doublereal) maxn / (doublereal) (*msub + 1)) / log(2.);
*lvl = (integer) temp + 1;
maxn = max(1, *n);
temp = log((doublereal)maxn / (doublereal)(*msub + 1)) / log(2.);
*lvl = (integer)temp + 1;
i__ = *n / 2;
inode[1] = i__ + 1;
ndiml[1] = i__;
@ -176,10 +25,6 @@ f"> */
llst = 1;
i__1 = *lvl - 1;
for (nlvl = 1; nlvl <= i__1; ++nlvl) {
/* Constructing the tree at (NLVL+1)-st level. The number of */
/* nodes created on this level is LLST * 2. */
i__2 = llst - 1;
for (i__ = 0; i__ <= i__2; ++i__) {
il += 2;
@ -191,19 +36,12 @@ f"> */
ndiml[ir] = ndimr[ncrnt] / 2;
ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1;
inode[ir] = inode[ncrnt] + ndiml[ir] + 1;
/* L10: */
}
llst <<= 1;
/* L20: */
}
*nd = (llst << 1) - 1;
return 0;
/* End of DLASDT */
} /* dlasdt_ */
}
#ifdef __cplusplus
}
}
#endif

195
lib/linalg/dlaset.cpp
View File

@ -1,229 +1,48 @@
/* fortran/dlaset.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given val
ues. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASET + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaset.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaset.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaset.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) */
/* .. Scalar Arguments .. */
/* CHARACTER UPLO */
/* INTEGER LDA, M, N */
/* DOUBLE PRECISION ALPHA, BETA */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASET initializes an m-by-n matrix A to BETA on the diagonal and */
/* > ALPHA on the offdiagonals. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] UPLO */
/* > \verbatim */
/* > UPLO is CHARACTER*1 */
/* > Specifies the part of the matrix A to be set. */
/* > = 'U': Upper triangular part is set; the strictly lower */
/* > triangular part of A is not changed. */
/* > = 'L': Lower triangular part is set; the strictly upper */
/* > triangular part of A is not changed. */
/* > Otherwise: All of the matrix A is set. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] ALPHA */
/* > \verbatim */
/* > ALPHA is DOUBLE PRECISION */
/* > The constant to which the offdiagonal elements are to be set. */
/* > \endverbatim */
/* > */
/* > \param[in] BETA */
/* > \verbatim */
/* > BETA is DOUBLE PRECISION */
/* > The constant to which the diagonal elements are to be set. */
/* > \endverbatim */
/* > */
/* > \param[out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On exit, the leading m-by-n submatrix of A is set as follows: */
/* > */
/* > if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */
/* > if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */
/* > otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */
/* > */
/* > and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal *
alpha, doublereal *beta, doublereal *a, integer *lda, ftnlen uplo_len)
int dlaset_(char *uplo, integer *m, integer *n, doublereal *alpha, doublereal *beta, doublereal *a,
integer *lda, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
/* Set the strictly upper triangular or trapezoidal part of the */
/* array to ALPHA. */
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__2 = min(i__3,*m);
i__2 = min(i__3, *m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L10: */
}
/* L20: */
}
} else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Set the strictly lower triangular or trapezoidal part of the */
/* array to ALPHA. */
i__1 = min(*m,*n);
i__1 = min(*m, *n);
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L30: */
}
/* L40: */
}
} else {
/* Set the leading m-by-n submatrix to ALPHA. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L50: */
}
/* L60: */
}
}
/* 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__) {
a[i__ + i__ * a_dim1] = *beta;
/* L70: */
}
return 0;
/* End of DLASET */
} /* dlaset_ */
}
#ifdef __cplusplus
}
}
#endif

230
lib/linalg/dlasq1.cpp
View File

@ -1,195 +1,33 @@
/* fortran/dlasq1.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c__2 = 2;
static integer c__0 = 0;
/* > \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASQ1 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq1.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq1.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq1.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( * ), E( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASQ1 computes the singular values of a real N-by-N bidiagonal */
/* > matrix with diagonal D and off-diagonal E. The singular values */
/* > are computed to high relative accuracy, in the absence of */
/* > denormalization, underflow and overflow. The algorithm was first */
/* > presented in */
/* > */
/* > (char *)"Accurate singular values and differential qd algorithms" by K. V. */
/* > Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */
/* > 1994, */
/* > */
/* > and the present implementation is described in "An implementation of */
/* > the dqds Algorithm (Positive Case)", LAPACK Working Note. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of rows and columns in the matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, D contains the diagonal elements of the */
/* > bidiagonal matrix whose SVD is desired. On normal exit, */
/* > D contains the singular values in decreasing order. */
/* > \endverbatim */
/* > */
/* > \param[in,out] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (N) */
/* > On entry, elements E(1:N-1) contain the off-diagonal elements */
/* > of the bidiagonal matrix whose SVD is desired. */
/* > On exit, E is overwritten. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (4*N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > > 0: the algorithm failed */
/* > = 1, a split was marked by a positive value in E */
/* > = 2, current block of Z not diagonalized after 100*N */
/* > iterations (in inner while loop) On exit D and E */
/* > represent a matrix with the same singular values */
/* > which the calling subroutine could use to finish the */
/* > computation, or even feed back into DLASQ1 */
/* > = 3, termination criterion of outer while loop not met */
/* > (program created more than N unreduced blocks) */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e,
doublereal *work, integer *info)
int dlasq1_(integer *n, doublereal *d__, doublereal *e, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal eps;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern int dlas2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
doublereal scale;
integer iinfo;
doublereal sigmn;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal sigmx;
extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *);
extern int dlasq2_(integer *, doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, ftnlen);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlasrt_(
char *, integer *, doublereal *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen),
dlasrt_(char *, integer *, doublereal *, integer *, ftnlen);
--work;
--e;
--d__;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
@ -207,38 +45,23 @@ f"> */
d__[2] = sigmn;
return 0;
}
/* Estimate the largest singular value. */
sigmx = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* Computing MAX */
d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1));
sigmx = max(d__2,d__3);
/* L10: */
sigmx = max(d__2, d__3);
}
d__[*n] = (d__1 = d__[*n], abs(d__1));
/* Early return if SIGMX is zero (matrix is already diagonal). */
if (sigmx == 0.) {
dlasrt_((char *)"D", n, &d__[1], &iinfo, (ftnlen)1);
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = sigmx, d__2 = d__[i__];
sigmx = max(d__1,d__2);
/* L20: */
sigmx = max(d__1, d__2);
}
/* Copy D and E into WORK (in the Z format) and scale (squaring the */
/* input data makes scaling by a power of the radix pointless). */
eps = dlamch_((char *)"Precision", (ftnlen)9);
safmin = dlamch_((char *)"Safe minimum", (ftnlen)12);
scale = sqrt(eps / safmin);
@ -247,52 +70,31 @@ f"> */
dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2);
i__1 = (*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,
&iinfo, (ftnlen)1);
/* Compute the q's and e's. */
dlascl_((char *)"G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, &iinfo, (ftnlen)1);
i__1 = (*n << 1) - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing 2nd power */
d__1 = work[i__];
work[i__] = d__1 * d__1;
/* L30: */
}
work[*n * 2] = 0.;
dlasq2_(n, &work[1], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(work[i__]);
/* L40: */
}
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
iinfo, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &iinfo, (ftnlen)1);
} else if (*info == 2) {
/* Maximum number of iterations exceeded. Move data from WORK */
/* into D and E so the calling subroutine can try to finish */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(work[(i__ << 1) - 1]);
e[i__] = sqrt(work[i__ * 2]);
}
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
iinfo, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo,
(ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &iinfo, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo, (ftnlen)1);
}
return 0;
/* End of DLASQ1 */
} /* dlasq1_ */
}
#ifdef __cplusplus
}
}
#endif

407
lib/linalg/dlasq2.cpp
View File

@ -1,152 +1,17 @@
/* fortran/dlasq2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c__2 = 2;
static integer c__10 = 10;
static integer c__3 = 3;
static integer c__4 = 4;
/* > \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix assoc
iated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASQ2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASQ2( N, Z, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASQ2 computes all the eigenvalues of the symmetric positive */
/* > definite tridiagonal matrix associated with the qd array Z to high */
/* > relative accuracy are computed to high relative accuracy, in the */
/* > absence of denormalization, underflow and overflow. */
/* > */
/* > To see the relation of Z to the tridiagonal matrix, let L be a */
/* > unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */
/* > let U be an upper bidiagonal matrix with 1's above and diagonal */
/* > Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */
/* > symmetric tridiagonal to which it is similar. */
/* > */
/* > Note : DLASQ2 defines a logical variable, IEEE, which is true */
/* > on machines which follow ieee-754 floating-point standard in their */
/* > handling of infinities and NaNs, and false otherwise. This variable */
/* > is passed to DLASQ3. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of rows and columns in the matrix. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( 4*N ) */
/* > On entry Z holds the qd array. On exit, entries 1 to N hold */
/* > the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */
/* > trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */
/* > N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */
/* > holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */
/* > shifts that failed. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if the i-th argument is a scalar and had an illegal */
/* > value, then INFO = -i, if the i-th argument is an */
/* > array and the j-entry had an illegal value, then */
/* > INFO = -(i*100+j) */
/* > > 0: the algorithm failed */
/* > = 1, a split was marked by a positive value in E */
/* > = 2, current block of Z not diagonalized after 100*N */
/* > iterations (in inner while loop). On exit Z holds */
/* > a qd array with the same eigenvalues as the given Z. */
/* > = 3, termination criterion of outer while loop not met */
/* > (program created more than N unreduced blocks) */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Local Variables: I0:N0 defines a current unreduced segment of Z. */
/* > The shifts are accumulated in SIGMA. Iteration count is in ITER. */
/* > Ping-pong is controlled by PP (alternates between 0 and 1). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasq2_(integer *n, doublereal *z__, integer *info)
int dlasq2_(integer *n, doublereal *z__, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal d__, e, g;
integer k;
doublereal s, t;
@ -168,60 +33,25 @@ f"> */
integer iinfo;
doublereal tempe, tempq;
integer ttype;
extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, logical *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern int dlasq3_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *, logical *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
doublereal deemin;
integer iwhila, iwhilb;
doublereal oldemn, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* (in case DLASQ2 is not called by DLASQ1) */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dlasrt_(char *, integer *, doublereal *, integer *, ftnlen);
--z__;
/* Function Body */
*info = 0;
eps = dlamch_((char *)"Precision", (ftnlen)9);
safmin = dlamch_((char *)"Safe minimum", (ftnlen)12);
tol = eps * 100.;
/* Computing 2nd power */
d__1 = tol;
tol2 = d__1 * d__1;
if (*n < 0) {
*info = -1;
xerbla_((char *)"DLASQ2", &c__1, (ftnlen)6);
@ -229,18 +59,12 @@ f"> */
} else if (*n == 0) {
return 0;
} else if (*n == 1) {
/* 1-by-1 case. */
if (z__[1] < 0.) {
*info = -201;
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
}
return 0;
} else if (*n == 2) {
/* 2-by-2 case. */
if (z__[1] < 0.) {
*info = -201;
xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6);
@ -275,16 +99,12 @@ f"> */
z__[6] = z__[2] + z__[1];
return 0;
}
/* Check for negative data and compute sums of q's and e's. */
z__[*n * 2] = 0.;
emin = z__[2];
qmax = 0.;
zmax = 0.;
d__ = 0.;
e = 0.;
i__1 = *n - 1 << 1;
for (k = 1; k <= i__1; k += 2) {
if (z__[k] < 0.) {
@ -298,16 +118,12 @@ f"> */
}
d__ += z__[k];
e += z__[k + 1];
/* Computing MAX */
d__1 = qmax, d__2 = z__[k];
qmax = max(d__1,d__2);
/* Computing MIN */
qmax = max(d__1, d__2);
d__1 = emin, d__2 = z__[k + 1];
emin = min(d__1,d__2);
/* Computing MAX */
d__1 = max(qmax,zmax), d__2 = z__[k + 1];
zmax = max(d__1,d__2);
/* L10: */
emin = min(d__1, d__2);
d__1 = max(qmax, zmax), d__2 = z__[k + 1];
zmax = max(d__1, d__2);
}
if (z__[(*n << 1) - 1] < 0.) {
*info = -((*n << 1) + 199);
@ -315,53 +131,32 @@ f"> */
return 0;
}
d__ += z__[(*n << 1) - 1];
/* Computing MAX */
d__1 = qmax, d__2 = z__[(*n << 1) - 1];
qmax = max(d__1,d__2);
zmax = max(qmax,zmax);
/* Check for diagonality. */
qmax = max(d__1, d__2);
zmax = max(qmax, zmax);
if (e == 0.) {
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 1) - 1];
/* L20: */
}
dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1);
z__[(*n << 1) - 1] = d__;
return 0;
}
trace = d__ + e;
/* Check for zero data. */
if (trace == 0.) {
z__[(*n << 1) - 1] = 0.;
return 0;
}
/* Check whether the machine is IEEE conformable. */
ieee = ilaenv_(&c__10, (char *)"DLASQ2", (char *)"N", &c__1, &c__2, &c__3, &c__4, (ftnlen)
6, (ftnlen)1) == 1;
/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */
ieee = ilaenv_(&c__10, (char *)"DLASQ2", (char *)"N", &c__1, &c__2, &c__3, &c__4, (ftnlen)6, (ftnlen)1) == 1;
for (k = *n << 1; k >= 2; k += -2) {
z__[k * 2] = 0.;
z__[(k << 1) - 1] = z__[k];
z__[(k << 1) - 2] = 0.;
z__[(k << 1) - 3] = z__[k - 1];
/* L30: */
}
i0 = 1;
n0 = *n;
/* Reverse the qd-array, if warranted. */
if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) {
ipn4 = i0 + n0 << 2;
i__1 = i0 + n0 - 1 << 1;
@ -372,16 +167,10 @@ f"> */
temp = z__[i4 - 1];
z__[i4 - 1] = z__[ipn4 - i4 - 5];
z__[ipn4 - i4 - 5] = temp;
/* L40: */
}
}
/* Initial split checking via dqd and Li's test. */
pp = 0;
for (k = 1; k <= 2; ++k) {
d__ = z__[(n0 << 2) + pp - 3];
i__1 = (i0 << 2) + pp;
for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) {
@ -391,11 +180,7 @@ f"> */
} else {
d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1]));
}
/* L50: */
}
/* dqd maps Z to ZZ plus Li's test. */
emin = z__[(i0 << 2) + pp + 1];
d__ = z__[(i0 << 2) + pp - 3];
i__1 = (n0 - 1 << 2) + pp;
@ -407,41 +192,26 @@ f"> */
z__[i4 - (pp << 1)] = 0.;
d__ = z__[i4 + 1];
} 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];
z__[i4 - (pp << 1)] = z__[i4 - 1] * temp;
d__ *= temp;
} else {
z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (
pp << 1) - 2]);
z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (pp << 1) - 2]);
d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]);
}
/* Computing MIN */
d__1 = emin, d__2 = z__[i4 - (pp << 1)];
emin = min(d__1,d__2);
/* L60: */
emin = min(d__1, d__2);
}
z__[(n0 << 2) - pp - 2] = d__;
/* Now find qmax. */
qmax = z__[(i0 << 2) - pp - 2];
i__1 = (n0 << 2) - pp - 2;
for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) {
/* Computing MAX */
d__1 = qmax, d__2 = z__[i4];
qmax = max(d__1,d__2);
/* L70: */
qmax = max(d__1, d__2);
}
/* Prepare for the next iteration on K. */
pp = 1 - pp;
/* L80: */
}
/* Initialise variables to pass to DLASQ3. */
ttype = 0;
dmin1 = 0.;
dmin2 = 0.;
@ -450,22 +220,14 @@ f"> */
dn2 = 0.;
g = 0.;
tau = 0.;
iter = 2;
nfail = 0;
ndiv = n0 - i0 << 1;
i__1 = *n + 1;
for (iwhila = 1; iwhila <= i__1; ++iwhila) {
if (n0 < 1) {
goto L170;
}
/* While array unfinished do */
/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */
/* splits from the rest of the array, but is negated. */
desig = 0.;
if (n0 == *n) {
sigma = 0.;
@ -476,10 +238,6 @@ f"> */
*info = 1;
return 0;
}
/* Find last unreduced submatrix's top index I0, find QMAX and */
/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */
emax = 0.;
if (n0 > i0) {
emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1));
@ -493,27 +251,20 @@ f"> */
goto L100;
}
if (qmin >= emax * 4.) {
/* Computing MIN */
d__1 = qmin, d__2 = z__[i4 - 3];
qmin = min(d__1,d__2);
/* Computing MAX */
qmin = min(d__1, d__2);
d__1 = emax, d__2 = z__[i4 - 5];
emax = max(d__1,d__2);
emax = max(d__1, d__2);
}
/* Computing MAX */
d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5];
qmax = max(d__1,d__2);
/* Computing MIN */
qmax = max(d__1, d__2);
d__1 = emin, d__2 = z__[i4 - 5];
emin = min(d__1,d__2);
/* L90: */
emin = min(d__1, d__2);
}
i4 = 4;
L100:
L100:
i0 = i4 / 4;
pp = 0;
if (n0 - i0 > 1) {
dee = z__[(i0 << 2) - 3];
deemin = dee;
@ -525,10 +276,8 @@ L100:
deemin = dee;
kmin = (i4 + 3) / 4;
}
/* L110: */
}
if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] *
.5) {
if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * .5) {
ipn4 = i0 + n0 << 2;
pp = 2;
i__2 = i0 + n0 - 1 << 1;
@ -545,87 +294,53 @@ L100:
temp = z__[i4];
z__[i4] = z__[ipn4 - i4 - 4];
z__[ipn4 - i4 - 4] = temp;
/* L120: */
}
}
}
/* Put -(initial shift) into DMIN. */
/* Computing MAX */
d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax);
dmin__ = -max(d__1,d__2);
/* Now I0:N0 is unreduced. */
/* PP = 0 for ping, PP = 1 for pong. */
/* PP = 2 indicates that flipping was applied to the Z array and */
/* and that the tests for deflation upon entry in DLASQ3 */
/* should not be performed. */
dmin__ = -max(d__1, d__2);
nbig = (n0 - i0 + 1) * 100;
i__2 = nbig;
for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) {
if (i0 > n0) {
goto L150;
}
/* While submatrix unfinished take a good dqds step. */
dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &
nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &
dn1, &dn2, &g, &tau);
dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &nfail, &iter, &ndiv,
&ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau);
pp = 1 - pp;
/* When EMIN is very small check for splits. */
if (pp == 0 && n0 - i0 >= 3) {
if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 *
sigma) {
if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * sigma) {
splt = i0 - 1;
qmax = z__[(i0 << 2) - 3];
emin = z__[(i0 << 2) - 1];
oldemn = z__[i0 * 4];
i__3 = n0 - 3 << 2;
for (i4 = i0 << 2; i4 <= i__3; i4 += 4) {
if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <=
tol2 * sigma) {
if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= tol2 * sigma) {
z__[i4 - 1] = -sigma;
splt = i4 / 4;
qmax = 0.;
emin = z__[i4 + 3];
oldemn = z__[i4 + 4];
} else {
/* Computing MAX */
d__1 = qmax, d__2 = z__[i4 + 1];
qmax = max(d__1,d__2);
/* Computing MIN */
qmax = max(d__1, d__2);
d__1 = emin, d__2 = z__[i4 - 1];
emin = min(d__1,d__2);
/* Computing MIN */
emin = min(d__1, d__2);
d__1 = oldemn, d__2 = z__[i4];
oldemn = min(d__1,d__2);
oldemn = min(d__1, d__2);
}
/* L130: */
}
z__[(n0 << 2) - 1] = emin;
z__[n0 * 4] = oldemn;
i0 = splt + 1;
}
}
/* L140: */
}
*info = 2;
/* Maximum number of iterations exceeded, restore the shift */
/* SIGMA and place the new d's and e's in a qd array. */
/* This might need to be done for several blocks */
i1 = i0;
n1 = n0;
L145:
L145:
tempq = z__[(i0 << 2) - 3];
z__[(i0 << 2) - 3] += sigma;
i__2 = n0;
@ -633,15 +348,11 @@ L145:
tempe = z__[(k << 2) - 5];
z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7];
tempq = z__[(k << 2) - 3];
z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k <<
2) - 5];
z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k << 2) - 5];
}
/* Prepare to do this on the previous block if there is one */
if (i1 > 1) {
n1 = i1 - 1;
while(i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) {
while (i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) {
--i1;
}
sigma = -z__[(n1 << 2) - 1];
@ -650,11 +361,6 @@ L145:
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
z__[(k << 1) - 1] = z__[(k << 2) - 3];
/* Only the block 1..N0 is unfinished. The rest of the e's */
/* must be essentially zero, although sometimes other data */
/* has been stored in them. */
if (k < n0) {
z__[k * 2] = z__[(k << 2) - 1];
} else {
@ -662,55 +368,28 @@ L145:
}
}
return 0;
/* end IWHILB */
L150:
/* L160: */
;
L150:;
}
*info = 3;
return 0;
/* end IWHILA */
L170:
/* Move q's to the front. */
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 2) - 3];
/* L180: */
}
/* Sort and compute sum of eigenvalues. */
dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1);
e = 0.;
for (k = *n; k >= 1; --k) {
e += z__[k];
/* L190: */
}
/* Store trace, sum(eigenvalues) and information on performance. */
z__[(*n << 1) + 1] = trace;
z__[(*n << 1) + 2] = e;
z__[(*n << 1) + 3] = (doublereal) iter;
/* Computing 2nd power */
z__[(*n << 1) + 3] = (doublereal)iter;
i__1 = *n;
z__[(*n << 1) + 4] = (doublereal) ndiv / (doublereal) (i__1 * i__1);
z__[(*n << 1) + 5] = nfail * 100. / (doublereal) iter;
z__[(*n << 1) + 4] = (doublereal)ndiv / (doublereal)(i__1 * i__1);
z__[(*n << 1) + 5] = nfail * 100. / (doublereal)iter;
return 0;
/* End of DLASQ2 */
} /* dlasq2_ */
}
#ifdef __cplusplus
}
}
#endif

365
lib/linalg/dlasq3.cpp
View File

@ -1,272 +1,37 @@
/* fortran/dlasq3.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASQ3 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq3.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq3.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq3.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, */
/* ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, */
/* DN2, G, TAU ) */
/* .. Scalar Arguments .. */
/* LOGICAL IEEE */
/* INTEGER I0, ITER, N0, NDIV, NFAIL, PP */
/* DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, */
/* $ QMAX, SIGMA, TAU */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */
/* > In case of failure it changes shifts, and tries again until output */
/* > is positive. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] I0 */
/* > \verbatim */
/* > I0 is INTEGER */
/* > First index. */
/* > \endverbatim */
/* > */
/* > \param[in,out] N0 */
/* > \verbatim */
/* > N0 is INTEGER */
/* > Last index. */
/* > \endverbatim */
/* > */
/* > \param[in,out] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( 4*N0 ) */
/* > Z holds the qd array. */
/* > \endverbatim */
/* > */
/* > \param[in,out] PP */
/* > \verbatim */
/* > PP is INTEGER */
/* > PP=0 for ping, PP=1 for pong. */
/* > PP=2 indicates that flipping was applied to the Z array */
/* > and that the initial tests for deflation should not be */
/* > performed. */
/* > \endverbatim */
/* > */
/* > \param[out] DMIN */
/* > \verbatim */
/* > DMIN is DOUBLE PRECISION */
/* > Minimum value of d. */
/* > \endverbatim */
/* > */
/* > \param[out] SIGMA */
/* > \verbatim */
/* > SIGMA is DOUBLE PRECISION */
/* > Sum of shifts used in current segment. */
/* > \endverbatim */
/* > */
/* > \param[in,out] DESIG */
/* > \verbatim */
/* > DESIG is DOUBLE PRECISION */
/* > Lower order part of SIGMA */
/* > \endverbatim */
/* > */
/* > \param[in] QMAX */
/* > \verbatim */
/* > QMAX is DOUBLE PRECISION */
/* > Maximum value of q. */
/* > \endverbatim */
/* > */
/* > \param[in,out] NFAIL */
/* > \verbatim */
/* > NFAIL is INTEGER */
/* > Increment NFAIL by 1 each time the shift was too big. */
/* > \endverbatim */
/* > */
/* > \param[in,out] ITER */
/* > \verbatim */
/* > ITER is INTEGER */
/* > Increment ITER by 1 for each iteration. */
/* > \endverbatim */
/* > */
/* > \param[in,out] NDIV */
/* > \verbatim */
/* > NDIV is INTEGER */
/* > Increment NDIV by 1 for each division. */
/* > \endverbatim */
/* > */
/* > \param[in] IEEE */
/* > \verbatim */
/* > IEEE is LOGICAL */
/* > Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). */
/* > \endverbatim */
/* > */
/* > \param[in,out] TTYPE */
/* > \verbatim */
/* > TTYPE is INTEGER */
/* > Shift type. */
/* > \endverbatim */
/* > */
/* > \param[in,out] DMIN1 */
/* > \verbatim */
/* > DMIN1 is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in,out] DMIN2 */
/* > \verbatim */
/* > DMIN2 is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in,out] DN */
/* > \verbatim */
/* > DN is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in,out] DN1 */
/* > \verbatim */
/* > DN1 is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in,out] DN2 */
/* > \verbatim */
/* > DN2 is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in,out] G */
/* > \verbatim */
/* > G is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[in,out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION */
/* > */
/* > These are passed as arguments in order to save their values */
/* > between calls to DLASQ3. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig,
doublereal *qmax, integer *nfail, integer *iter, integer *ndiv,
logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g,
doublereal *tau)
int dlasq3_(integer *i0, integer *n0, doublereal *z__, integer *pp, doublereal *dmin__,
doublereal *sigma, doublereal *desig, doublereal *qmax, integer *nfail, integer *iter,
integer *ndiv, logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g, doublereal *tau)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal s, t;
integer j4, nn;
doublereal eps, tol;
integer n0in, ipn4;
doublereal tol2, temp;
extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *), dlasq5_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, logical *
, doublereal *), dlasq6_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
extern int dlasq4_(integer *, integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *),
dlasq5_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
logical *, doublereal *),
dlasq6_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern logical disnan_(doublereal *);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
n0in = *n0;
eps = dlamch_((char *)"Precision", (ftnlen)9);
tol = eps * 100.;
/* Computing 2nd power */
d__1 = tol;
tol2 = d__1 * d__1;
/* Check for deflation. */
L10:
if (*n0 < *i0) {
return 0;
}
@ -277,31 +42,19 @@ L10:
if (*n0 == *i0 + 1) {
goto L40;
}
/* Check whether E(N0-1) is negligible, 1 eigenvalue. */
if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
4] > tol2 * z__[nn - 7]) {
if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) &&
z__[nn - (*pp << 1) - 4] > tol2 * z__[nn - 7]) {
goto L30;
}
L20:
z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
--(*n0);
goto L10;
/* Check whether E(N0-2) is negligible, 2 eigenvalues. */
L30:
if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
nn - 11]) {
if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[nn - 11]) {
goto L50;
}
L40:
if (z__[nn - 3] > z__[nn - 7]) {
s = z__[nn - 3];
z__[nn - 3] = z__[nn - 7];
@ -323,14 +76,10 @@ L40:
z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
*n0 += -2;
goto L10;
L50:
if (*pp == 2) {
*pp = 0;
}
/* Reverse the qd-array, if warranted. */
if (*dmin__ <= 0. || *n0 < n0in) {
if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) {
ipn4 = *i0 + *n0 << 2;
@ -348,90 +97,50 @@ L50:
temp = z__[j4];
z__[j4] = z__[ipn4 - j4 - 4];
z__[ipn4 - j4 - 4] = temp;
/* L60: */
}
if (*n0 - *i0 <= 4) {
z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
}
/* Computing MIN */
d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1];
*dmin2 = min(d__1,d__2);
/* Computing MIN */
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];
z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2);
/* Computing MIN */
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];
z__[(*n0 << 2) - *pp] = min(d__1,d__2);
/* Computing MAX */
d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1,
d__2), d__2 = z__[(*i0 << 2) + *pp + 1];
*qmax = max(d__1,d__2);
*dmin2 = min(d__1, d__2);
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];
z__[(*n0 << 2) + *pp - 1] = min(d__1, d__2);
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];
z__[(*n0 << 2) - *pp] = min(d__1, d__2);
d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1, d__2),
d__2 = z__[(*i0 << 2) + *pp + 1];
*qmax = max(d__1, d__2);
*dmin__ = -0.;
}
}
/* Choose a shift. */
dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
tau, ttype, g);
/* Call dqds until DMIN > 0. */
dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g);
L70:
dlasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1,
dn2, ieee, &eps);
dlasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1, dn2, ieee, &eps);
*ndiv += *n0 - *i0 + 2;
++(*iter);
/* Check status. */
if (*dmin__ >= 0. && *dmin1 >= 0.) {
/* Success. */
goto L90;
} else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol
* (*sigma + *dn1) && abs(*dn) < tol * *sigma) {
/* Convergence hidden by negative DN. */
} else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol * (*sigma + *dn1) &&
abs(*dn) < tol * *sigma) {
z__[(*n0 - 1 << 2) - *pp + 2] = 0.;
*dmin__ = 0.;
goto L90;
} else if (*dmin__ < 0.) {
/* TAU too big. Select new TAU and try again. */
++(*nfail);
if (*ttype < -22) {
/* Failed twice. Play it safe. */
*tau = 0.;
} else if (*dmin1 > 0.) {
/* Late failure. Gives excellent shift. */
*tau = (*tau + *dmin__) * (1. - eps * 2.);
*ttype += -11;
} else {
/* Early failure. Divide by 4. */
*tau *= .25;
*ttype += -12;
}
goto L70;
} else if (disnan_(dmin__)) {
/* NaN. */
if (*tau == 0.) {
goto L80;
} else {
@ -439,20 +148,13 @@ L70:
goto L70;
}
} else {
/* Possible underflow. Play it safe. */
goto L80;
}
/* Risk of underflow. */
L80:
dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
*ndiv += *n0 - *i0 + 2;
++(*iter);
*tau = 0.;
L90:
if (*tau < *sigma) {
*desig += *tau;
@ -463,13 +165,8 @@ L90:
*desig = *sigma - (t - *tau) + *desig;
}
*sigma = t;
return 0;
/* End of DLASQ3 */
} /* dlasq3_ */
}
#ifdef __cplusplus
}
}
#endif

306
lib/linalg/dlasq4.cpp
View File

@ -1,235 +1,29 @@
/* fortran/dlasq4.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous
transform. Used by sbdsqr. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASQ4 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq4.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq4.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq4.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, */
/* DN1, DN2, TAU, TTYPE, G ) */
/* .. Scalar Arguments .. */
/* INTEGER I0, N0, N0IN, PP, TTYPE */
/* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASQ4 computes an approximation TAU to the smallest eigenvalue */
/* > using values of d from the previous transform. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] I0 */
/* > \verbatim */
/* > I0 is INTEGER */
/* > First index. */
/* > \endverbatim */
/* > */
/* > \param[in] N0 */
/* > \verbatim */
/* > N0 is INTEGER */
/* > Last index. */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( 4*N0 ) */
/* > Z holds the qd array. */
/* > \endverbatim */
/* > */
/* > \param[in] PP */
/* > \verbatim */
/* > PP is INTEGER */
/* > PP=0 for ping, PP=1 for pong. */
/* > \endverbatim */
/* > */
/* > \param[in] N0IN */
/* > \verbatim */
/* > N0IN is INTEGER */
/* > The value of N0 at start of EIGTEST. */
/* > \endverbatim */
/* > */
/* > \param[in] DMIN */
/* > \verbatim */
/* > DMIN is DOUBLE PRECISION */
/* > Minimum value of d. */
/* > \endverbatim */
/* > */
/* > \param[in] DMIN1 */
/* > \verbatim */
/* > DMIN1 is DOUBLE PRECISION */
/* > Minimum value of d, excluding D( N0 ). */
/* > \endverbatim */
/* > */
/* > \param[in] DMIN2 */
/* > \verbatim */
/* > DMIN2 is DOUBLE PRECISION */
/* > Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* > \endverbatim */
/* > */
/* > \param[in] DN */
/* > \verbatim */
/* > DN is DOUBLE PRECISION */
/* > d(N) */
/* > \endverbatim */
/* > */
/* > \param[in] DN1 */
/* > \verbatim */
/* > DN1 is DOUBLE PRECISION */
/* > d(N-1) */
/* > \endverbatim */
/* > */
/* > \param[in] DN2 */
/* > \verbatim */
/* > DN2 is DOUBLE PRECISION */
/* > d(N-2) */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION */
/* > This is the shift. */
/* > \endverbatim */
/* > */
/* > \param[out] TTYPE */
/* > \verbatim */
/* > TTYPE is INTEGER */
/* > Shift type. */
/* > \endverbatim */
/* > */
/* > \param[in,out] G */
/* > \verbatim */
/* > G is DOUBLE PRECISION */
/* > G is passed as an argument in order to save its value between */
/* > calls to DLASQ4. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > CNST1 = 9/16 */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__,
integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1,
doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2,
doublereal *tau, integer *ttype, doublereal *g)
int dlasq4_(integer *i0, integer *n0, doublereal *z__, integer *pp, integer *n0in,
doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, doublereal *dn,
doublereal *dn1, doublereal *dn2, doublereal *tau, integer *ttype, doublereal *g)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal s, a2, b1, b2;
integer i4, nn, np;
doublereal gam, gap1, gap2;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* A negative DMIN forces the shift to take that absolute value */
/* TTYPE records the type of shift. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*dmin__ <= 0.) {
*tau = -(*dmin__);
*ttype = -1;
return 0;
}
nn = (*n0 << 2) + *pp;
if (*n0in == *n0) {
/* No eigenvalues deflated. */
if (*dmin__ == *dn || *dmin__ == *dn1) {
b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
a2 = z__[nn - 7] + z__[nn - 5];
/* Cases 2 and 3. */
if (*dmin__ == *dn && *dmin1 == *dn1) {
gap2 = *dmin2 - a2 - *dmin2 * .25;
if (gap2 > 0. && gap2 > b2) {
@ -238,9 +32,8 @@ f"> */
gap1 = a2 - *dn - (b1 + b2);
}
if (gap1 > 0. && gap1 > b1) {
/* Computing MAX */
d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5;
s = max(d__1,d__2);
s = max(d__1, d__2);
*ttype = -2;
} else {
s = 0.;
@ -248,19 +41,14 @@ f"> */
s = *dn - b1;
}
if (a2 > b1 + b2) {
/* Computing MIN */
d__1 = s, d__2 = a2 - (b1 + b2);
s = min(d__1,d__2);
s = min(d__1, d__2);
}
/* Computing MAX */
d__1 = s, d__2 = *dmin__ * .333;
s = max(d__1,d__2);
s = max(d__1, d__2);
*ttype = -3;
}
} else {
/* Case 4. */
*ttype = -4;
s = *dmin__ * .25;
if (*dmin__ == *dn) {
@ -284,9 +72,6 @@ f"> */
b2 = z__[nn - 9] / z__[nn - 11];
np = nn - 13;
}
/* Approximate contribution to norm squared from I < NN-1. */
a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = np; i4 >= i__1; i4 += -4) {
@ -299,29 +84,19 @@ f"> */
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (max(b2,b1) * 100. < a2 || .563 < a2) {
if (max(b2, b1) * 100. < a2 || .563 < a2) {
goto L20;
}
/* L10: */
}
L20:
L20:
a2 *= 1.05;
/* Rayleigh quotient residual bound. */
if (a2 < .563) {
s = gam * (1. - sqrt(a2)) / (a2 + 1.);
}
}
} else if (*dmin__ == *dn2) {
/* Case 5. */
*ttype = -5;
s = *dmin__ * .25;
/* Compute contribution to norm squared from I > NN-2. */
np = nn - (*pp << 1);
b1 = z__[np - 2];
b2 = z__[np - 6];
@ -330,9 +105,6 @@ L20:
return 0;
}
a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.);
/* Approximate contribution to norm squared from I < NN-2. */
if (*n0 - *i0 > 2) {
b2 = z__[nn - 13] / z__[nn - 15];
a2 += b2;
@ -347,22 +119,17 @@ L20:
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (max(b2,b1) * 100. < a2 || .563 < a2) {
if (max(b2, b1) * 100. < a2 || .563 < a2) {
goto L40;
}
/* L30: */
}
L40:
L40:
a2 *= 1.05;
}
if (a2 < .563) {
s = gam * (1. - sqrt(a2)) / (a2 + 1.);
}
} else {
/* Case 6, no information to guide us. */
if (*ttype == -6) {
*g += (1. - *g) * .333;
} else if (*ttype == -18) {
@ -373,15 +140,8 @@ L40:
s = *g * *dmin__;
*ttype = -6;
}
} else if (*n0in == *n0 + 1) {
/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
if (*dmin1 == *dn1 && *dmin2 == *dn2) {
/* Cases 7 and 8. */
*ttype = -7;
s = *dmin1 * .333;
if (z__[nn - 5] > z__[nn - 7]) {
@ -400,44 +160,31 @@ L40:
}
b1 *= z__[i4] / z__[i4 - 2];
b2 += b1;
if (max(b1,a2) * 100. < b2) {
if (max(b1, a2) * 100. < b2) {
goto L60;
}
/* L50: */
}
L60:
L60:
b2 = sqrt(b2 * 1.05);
/* Computing 2nd power */
d__1 = b2;
a2 = *dmin1 / (d__1 * d__1 + 1.);
gap2 = *dmin2 * .5 - a2;
if (gap2 > 0. && gap2 > b2 * a2) {
/* Computing MAX */
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 {
/* Computing MAX */
d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
s = max(d__1,d__2);
s = max(d__1, d__2);
*ttype = -8;
}
} else {
/* Case 9. */
s = *dmin1 * .25;
if (*dmin1 == *dn1) {
s = *dmin1 * .5;
}
*ttype = -9;
}
} else if (*n0in == *n0 + 2) {
/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
/* Cases 10 and 11. */
if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) {
*ttype = -10;
s = *dmin2 * .333;
@ -459,43 +206,30 @@ L60:
if (b1 * 100. < b2) {
goto L80;
}
/* L70: */
}
L80:
L80:
b2 = sqrt(b2 * 1.05);
/* Computing 2nd power */
d__1 = b2;
a2 = *dmin2 / (d__1 * d__1 + 1.);
gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
nn - 9]) - a2;
gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[nn - 9]) - a2;
if (gap2 > 0. && gap2 > b2 * a2) {
/* Computing MAX */
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 {
/* Computing MAX */
d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
s = max(d__1,d__2);
s = max(d__1, d__2);
}
} else {
s = *dmin2 * .25;
*ttype = -11;
}
} else if (*n0in > *n0 + 2) {
/* Case 12, more than two eigenvalues deflated. No information. */
s = 0.;
*ttype = -12;
}
*tau = s;
return 0;
/* End of DLASQ4 */
} /* dlasq4_ */
}
#ifdef __cplusplus
}
}
#endif

299
lib/linalg/dlasq5.cpp
View File

@ -1,206 +1,20 @@
/* fortran/dlasq5.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASQ5 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq5.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq5.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq5.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, */
/* DNM1, DNM2, IEEE, EPS ) */
/* .. Scalar Arguments .. */
/* LOGICAL IEEE */
/* INTEGER I0, N0, PP */
/* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASQ5 computes one dqds transform in ping-pong form, one */
/* > version for IEEE machines another for non IEEE machines. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] I0 */
/* > \verbatim */
/* > I0 is INTEGER */
/* > First index. */
/* > \endverbatim */
/* > */
/* > \param[in] N0 */
/* > \verbatim */
/* > N0 is INTEGER */
/* > Last index. */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( 4*N ) */
/* > Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
/* > an extra argument. */
/* > \endverbatim */
/* > */
/* > \param[in] PP */
/* > \verbatim */
/* > PP is INTEGER */
/* > PP=0 for ping, PP=1 for pong. */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION */
/* > This is the shift. */
/* > \endverbatim */
/* > */
/* > \param[in] SIGMA */
/* > \verbatim */
/* > SIGMA is DOUBLE PRECISION */
/* > This is the accumulated shift up to this step. */
/* > \endverbatim */
/* > */
/* > \param[out] DMIN */
/* > \verbatim */
/* > DMIN is DOUBLE PRECISION */
/* > Minimum value of d. */
/* > \endverbatim */
/* > */
/* > \param[out] DMIN1 */
/* > \verbatim */
/* > DMIN1 is DOUBLE PRECISION */
/* > Minimum value of d, excluding D( N0 ). */
/* > \endverbatim */
/* > */
/* > \param[out] DMIN2 */
/* > \verbatim */
/* > DMIN2 is DOUBLE PRECISION */
/* > Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* > \endverbatim */
/* > */
/* > \param[out] DN */
/* > \verbatim */
/* > DN is DOUBLE PRECISION */
/* > d(N0), the last value of d. */
/* > \endverbatim */
/* > */
/* > \param[out] DNM1 */
/* > \verbatim */
/* > DNM1 is DOUBLE PRECISION */
/* > d(N0-1). */
/* > \endverbatim */
/* > */
/* > \param[out] DNM2 */
/* > \verbatim */
/* > DNM2 is DOUBLE PRECISION */
/* > d(N0-2). */
/* > \endverbatim */
/* > */
/* > \param[in] IEEE */
/* > \verbatim */
/* > IEEE is LOGICAL */
/* > Flag for IEEE or non IEEE arithmetic. */
/* > \endverbatim */
/* > */
/* > \param[in] EPS */
/* > \verbatim */
/* > EPS is DOUBLE PRECISION */
/* > This is the value of epsilon used. */
/* > \endverbatim */
/* > */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *tau, doublereal *sigma, doublereal *dmin__,
doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *
dnm1, doublereal *dnm2, logical *ieee, doublereal *eps)
int dlasq5_(integer *i0, integer *n0, doublereal *z__, integer *pp, doublereal *tau,
doublereal *sigma, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dnm1, doublereal *dnm2, logical *ieee, doublereal *eps)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal d__;
integer j4, j4p2;
doublereal emin, temp, dthresh;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameter .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*n0 - *i0 - 1 <= 0) {
return 0;
}
dthresh = *eps * (*sigma + *tau);
if (*tau < dthresh * .5) {
*tau = 0.;
@ -211,23 +25,17 @@ f"> */
d__ = z__[j4] - *tau;
*dmin__ = d__;
*dmin1 = -z__[j4];
if (*ieee) {
/* Code for IEEE arithmetic. */
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
temp = z__[j4 + 1] / z__[j4 - 2];
d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__);
*dmin__ = min(*dmin__, d__);
z__[j4] = z__[j4 - 1] * temp;
/* Computing MIN */
d__1 = z__[j4];
emin = min(d__1,emin);
/* L10: */
emin = min(d__1, emin);
}
} else {
i__1 = *n0 - 3 << 2;
@ -235,17 +43,12 @@ f"> */
z__[j4 - 3] = d__ + z__[j4];
temp = z__[j4 + 2] / z__[j4 - 3];
d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__);
*dmin__ = min(*dmin__, d__);
z__[j4 - 1] = z__[j4] * temp;
/* Computing MIN */
d__1 = z__[j4 - 1];
emin = min(d__1,emin);
/* L20: */
emin = min(d__1, emin);
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
@ -253,20 +56,15 @@ f"> */
z__[j4 - 2] = *dnm2 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dnm1);
*dmin__ = min(*dmin__, *dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dn);
*dmin__ = min(*dmin__, *dn);
} else {
/* Code for non IEEE arithmetic. */
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
@ -277,11 +75,9 @@ f"> */
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
*dmin__ = min(*dmin__, d__);
d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2);
/* L30: */
emin = min(d__1, d__2);
}
} else {
i__1 = *n0 - 3 << 2;
@ -293,16 +89,11 @@ f"> */
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
*dmin__ = min(*dmin__, d__);
d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2);
/* L40: */
emin = min(d__1, d__2);
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
@ -314,8 +105,7 @@ f"> */
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dnm1);
*dmin__ = min(*dmin__, *dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
@ -326,20 +116,15 @@ f"> */
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dn);
*dmin__ = min(*dmin__, *dn);
}
} else {
/* This is the version that sets d's to zero if they are small enough */
j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4];
d__ = z__[j4] - *tau;
*dmin__ = d__;
*dmin1 = -z__[j4];
if (*ieee) {
/* Code for IEEE arithmetic. */
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
@ -349,12 +134,10 @@ f"> */
if (d__ < dthresh) {
d__ = 0.;
}
*dmin__ = min(*dmin__,d__);
*dmin__ = min(*dmin__, d__);
z__[j4] = z__[j4 - 1] * temp;
/* Computing MIN */
d__1 = z__[j4];
emin = min(d__1,emin);
/* L50: */
emin = min(d__1, emin);
}
} else {
i__1 = *n0 - 3 << 2;
@ -365,17 +148,12 @@ f"> */
if (d__ < dthresh) {
d__ = 0.;
}
*dmin__ = min(*dmin__,d__);
*dmin__ = min(*dmin__, d__);
z__[j4 - 1] = z__[j4] * temp;
/* Computing MIN */
d__1 = z__[j4 - 1];
emin = min(d__1,emin);
/* L60: */
emin = min(d__1, emin);
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
@ -383,20 +161,15 @@ f"> */
z__[j4 - 2] = *dnm2 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dnm1);
*dmin__ = min(*dmin__, *dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dn);
*dmin__ = min(*dmin__, *dn);
} else {
/* Code for non IEEE arithmetic. */
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
@ -410,11 +183,9 @@ f"> */
if (d__ < dthresh) {
d__ = 0.;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
*dmin__ = min(*dmin__, d__);
d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2);
/* L70: */
emin = min(d__1, d__2);
}
} else {
i__1 = *n0 - 3 << 2;
@ -429,16 +200,11 @@ f"> */
if (d__ < dthresh) {
d__ = 0.;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
*dmin__ = min(*dmin__, d__);
d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2);
/* L80: */
emin = min(d__1, d__2);
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
@ -450,8 +216,7 @@ f"> */
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dnm1);
*dmin__ = min(*dmin__, *dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
@ -462,19 +227,13 @@ f"> */
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dn);
*dmin__ = min(*dmin__, *dn);
}
}
z__[j4 + 2] = *dn;
z__[(*n0 << 2) - *pp] = emin;
return 0;
/* End of DLASQ5 */
} /* dlasq5_ */
}
#ifdef __cplusplus
}
}
#endif

210
lib/linalg/dlasq6.cpp
View File

@ -1,190 +1,27 @@
/* fortran/dlasq6.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASQ6 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq6.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq6.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq6.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, */
/* DNM1, DNM2 ) */
/* .. Scalar Arguments .. */
/* INTEGER I0, N0, PP */
/* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION Z( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASQ6 computes one dqd (shift equal to zero) transform in */
/* > ping-pong form, with protection against underflow and overflow. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] I0 */
/* > \verbatim */
/* > I0 is INTEGER */
/* > First index. */
/* > \endverbatim */
/* > */
/* > \param[in] N0 */
/* > \verbatim */
/* > N0 is INTEGER */
/* > Last index. */
/* > \endverbatim */
/* > */
/* > \param[in] Z */
/* > \verbatim */
/* > Z is DOUBLE PRECISION array, dimension ( 4*N ) */
/* > Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
/* > an extra argument. */
/* > \endverbatim */
/* > */
/* > \param[in] PP */
/* > \verbatim */
/* > PP is INTEGER */
/* > PP=0 for ping, PP=1 for pong. */
/* > \endverbatim */
/* > */
/* > \param[out] DMIN */
/* > \verbatim */
/* > DMIN is DOUBLE PRECISION */
/* > Minimum value of d. */
/* > \endverbatim */
/* > */
/* > \param[out] DMIN1 */
/* > \verbatim */
/* > DMIN1 is DOUBLE PRECISION */
/* > Minimum value of d, excluding D( N0 ). */
/* > \endverbatim */
/* > */
/* > \param[out] DMIN2 */
/* > \verbatim */
/* > DMIN2 is DOUBLE PRECISION */
/* > Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* > \endverbatim */
/* > */
/* > \param[out] DN */
/* > \verbatim */
/* > DN is DOUBLE PRECISION */
/* > d(N0), the last value of d. */
/* > \endverbatim */
/* > */
/* > \param[out] DNM1 */
/* > \verbatim */
/* > DNM1 is DOUBLE PRECISION */
/* > d(N0-1). */
/* > \endverbatim */
/* > */
/* > \param[out] DNM2 */
/* > \verbatim */
/* > DNM2 is DOUBLE PRECISION */
/* > d(N0-2). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dnm1, doublereal *dnm2)
int dlasq6_(integer *i0, integer *n0, doublereal *z__, integer *pp, doublereal *dmin__,
doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *dnm1,
doublereal *dnm2)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal d__;
integer j4, j4p2;
doublereal emin, temp;
extern doublereal dlamch_(char *, ftnlen);
doublereal safmin;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameter .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*n0 - *i0 - 1 <= 0) {
return 0;
}
safmin = dlamch_((char *)"Safe minimum", (ftnlen)12);
j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4];
d__ = z__[j4];
*dmin__ = d__;
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
@ -194,8 +31,7 @@ f"> */
d__ = z__[j4 + 1];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
- 2] < z__[j4 + 1]) {
} else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 - 2] < z__[j4 + 1]) {
temp = z__[j4 + 1] / z__[j4 - 2];
z__[j4] = z__[j4 - 1] * temp;
d__ *= temp;
@ -203,11 +39,9 @@ f"> */
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
*dmin__ = min(*dmin__, d__);
d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2);
/* L10: */
emin = min(d__1, d__2);
}
} else {
i__1 = *n0 - 3 << 2;
@ -218,8 +52,7 @@ f"> */
d__ = z__[j4 + 2];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
- 3] < z__[j4 + 2]) {
} else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 - 3] < z__[j4 + 2]) {
temp = z__[j4 + 2] / z__[j4 - 3];
z__[j4 - 1] = z__[j4] * temp;
d__ *= temp;
@ -227,16 +60,11 @@ f"> */
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
*dmin__ = min(*dmin__, d__);
d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2);
/* L20: */
emin = min(d__1, d__2);
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
@ -247,8 +75,7 @@ f"> */
*dnm1 = z__[j4p2 + 2];
*dmin__ = *dnm1;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dnm1 = *dnm2 * temp;
@ -256,8 +83,7 @@ f"> */
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,*dnm1);
*dmin__ = min(*dmin__, *dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
@ -267,8 +93,7 @@ f"> */
*dn = z__[j4p2 + 2];
*dmin__ = *dn;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dn = *dnm1 * temp;
@ -276,16 +101,11 @@ f"> */
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,*dn);
*dmin__ = min(*dmin__, *dn);
z__[j4 + 2] = *dn;
z__[(*n0 << 2) - *pp] = emin;
return 0;
/* End of DLASQ6 */
} /* dlasq6_ */
}
#ifdef __cplusplus
}
}
#endif

383
lib/linalg/dlasr.cpp
View File

@ -1,300 +1,47 @@
/* fortran/dlasr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASR + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasr.f
"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasr.f
"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasr.f
"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) */
/* .. Scalar Arguments .. */
/* CHARACTER DIRECT, PIVOT, SIDE */
/* INTEGER LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASR applies a sequence of plane rotations to a real matrix A, */
/* > from either the left or the right. */
/* > */
/* > When SIDE = 'L', the transformation takes the form */
/* > */
/* > A := P*A */
/* > */
/* > and when SIDE = 'R', the transformation takes the form */
/* > */
/* > A := A*P**T */
/* > */
/* > where P is an orthogonal matrix consisting of a sequence of z plane */
/* > rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */
/* > and P**T is the transpose of P. */
/* > */
/* > When DIRECT = 'F' (Forward sequence), then */
/* > */
/* > P = P(z-1) * ... * P(2) * P(1) */
/* > */
/* > and when DIRECT = 'B' (Backward sequence), then */
/* > */
/* > P = P(1) * P(2) * ... * P(z-1) */
/* > */
/* > where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */
/* > */
/* > R(k) = ( c(k) s(k) ) */
/* > = ( -s(k) c(k) ). */
/* > */
/* > When PIVOT = 'V' (Variable pivot), the rotation is performed */
/* > for the plane (k,k+1), i.e., P(k) has the form */
/* > */
/* > P(k) = ( 1 ) */
/* > ( ... ) */
/* > ( 1 ) */
/* > ( c(k) s(k) ) */
/* > ( -s(k) c(k) ) */
/* > ( 1 ) */
/* > ( ... ) */
/* > ( 1 ) */
/* > */
/* > where R(k) appears as a rank-2 modification to the identity matrix in */
/* > rows and columns k and k+1. */
/* > */
/* > When PIVOT = 'T' (Top pivot), the rotation is performed for the */
/* > plane (1,k+1), so P(k) has the form */
/* > */
/* > P(k) = ( c(k) s(k) ) */
/* > ( 1 ) */
/* > ( ... ) */
/* > ( 1 ) */
/* > ( -s(k) c(k) ) */
/* > ( 1 ) */
/* > ( ... ) */
/* > ( 1 ) */
/* > */
/* > where R(k) appears in rows and columns 1 and k+1. */
/* > */
/* > Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */
/* > performed for the plane (k,z), giving P(k) the form */
/* > */
/* > P(k) = ( 1 ) */
/* > ( ... ) */
/* > ( 1 ) */
/* > ( c(k) s(k) ) */
/* > ( 1 ) */
/* > ( ... ) */
/* > ( 1 ) */
/* > ( -s(k) c(k) ) */
/* > */
/* > where R(k) appears in rows and columns k and z. The rotations are */
/* > performed without ever forming P(k) explicitly. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > Specifies whether the plane rotation matrix P is applied to */
/* > A on the left or the right. */
/* > = 'L': Left, compute A := P*A */
/* > = 'R': Right, compute A:= A*P**T */
/* > \endverbatim */
/* > */
/* > \param[in] PIVOT */
/* > \verbatim */
/* > PIVOT is CHARACTER*1 */
/* > Specifies the plane for which P(k) is a plane rotation */
/* > matrix. */
/* > = 'V': Variable pivot, the plane (k,k+1) */
/* > = 'T': Top pivot, the plane (1,k+1) */
/* > = 'B': Bottom pivot, the plane (k,z) */
/* > \endverbatim */
/* > */
/* > \param[in] DIRECT */
/* > \verbatim */
/* > DIRECT is CHARACTER*1 */
/* > Specifies whether P is a forward or backward sequence of */
/* > plane rotations. */
/* > = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */
/* > = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix A. If m <= 1, an immediate */
/* > return is effected. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. If n <= 1, an */
/* > immediate return is effected. */
/* > \endverbatim */
/* > */
/* > \param[in] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension */
/* > (M-1) if SIDE = 'L' */
/* > (N-1) if SIDE = 'R' */
/* > The cosines c(k) of the plane rotations. */
/* > \endverbatim */
/* > */
/* > \param[in] S */
/* > \verbatim */
/* > S is DOUBLE PRECISION array, dimension */
/* > (M-1) if SIDE = 'L' */
/* > (N-1) if SIDE = 'R' */
/* > The sines s(k) of the plane rotations. The 2-by-2 plane */
/* > rotation part of the matrix P(k), R(k), has the form */
/* > R(k) = ( c(k) s(k) ) */
/* > ( -s(k) c(k) ). */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > The M-by-N matrix A. On exit, A is overwritten by P*A if */
/* > SIDE = 'L' or by A*P**T if SIDE = 'R'. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m,
integer *n, doublereal *c__, doublereal *s, doublereal *a, integer *
lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len)
int dlasr_(char *side, char *pivot, char *direct, integer *m, integer *n, doublereal *c__,
doublereal *s, doublereal *a, integer *lda, ftnlen side_len, ftnlen pivot_len,
ftnlen direct_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, j, info;
doublereal temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal ctemp, stemp;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
extern int xerbla_(char *, integer *, ftnlen);
--c__;
--s;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
info = 0;
if (! (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", (
ftnlen)1, (ftnlen)1))) {
if (!(lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1))) {
info = 1;
} else if (! (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || lsame_(pivot,
(char *)"T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, (char *)"B", (ftnlen)1, (
ftnlen)1))) {
} else if (!(lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) ||
lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1) ||
lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1))) {
info = 2;
} else if (! (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(direct,
(char *)"B", (ftnlen)1, (ftnlen)1))) {
} else if (!(lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) ||
lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1))) {
info = 3;
} else if (*m < 0) {
info = 4;
} else if (*n < 0) {
info = 5;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
info = 9;
}
if (info != 0) {
xerbla_((char *)"DLASR ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
/* Form P * A */
if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *m - 1;
@ -305,14 +52,10 @@ extern "C" {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1];
/* L10: */
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + i__ * a_dim1];
}
}
/* L20: */
}
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *m - 1; j >= 1; --j) {
@ -322,14 +65,10 @@ extern "C" {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1];
/* L30: */
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + i__ * a_dim1];
}
}
/* L40: */
}
}
} else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) {
@ -342,14 +81,10 @@ extern "C" {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1];
/* L50: */
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[i__ * a_dim1 + 1];
}
}
/* L60: */
}
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *m; j >= 2; --j) {
@ -359,14 +94,10 @@ extern "C" {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1];
/* L70: */
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[i__ * a_dim1 + 1];
}
}
/* L80: */
}
}
} else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) {
@ -379,14 +110,10 @@ extern "C" {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp;
/* L90: */
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a_dim1] - stemp * temp;
}
}
/* L100: */
}
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *m - 1; j >= 1; --j) {
@ -396,21 +123,14 @@ extern "C" {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp;
/* L110: */
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a_dim1] - stemp * temp;
}
}
/* L120: */
}
}
}
} else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
/* Form A * P**T */
if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) {
if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) {
i__1 = *n - 1;
@ -421,14 +141,10 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1];
/* L130: */
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[i__ + j * a_dim1];
}
}
/* L140: */
}
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *n - 1; j >= 1; --j) {
@ -438,14 +154,10 @@ extern "C" {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1];
/* L150: */
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[i__ + j * a_dim1];
}
}
/* L160: */
}
}
} else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) {
@ -458,14 +170,10 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1];
/* L170: */
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a_dim1];
}
}
/* L180: */
}
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *n; j >= 2; --j) {
@ -475,14 +183,10 @@ extern "C" {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1];
/* L190: */
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a_dim1];
}
}
/* L200: */
}
}
} else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) {
@ -495,14 +199,10 @@ extern "C" {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp;
/* L210: */
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a_dim1] - stemp * temp;
}
}
/* L220: */
}
} else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) {
for (j = *n - 1; j >= 1; --j) {
@ -512,25 +212,16 @@ extern "C" {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp;
/* L230: */
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a_dim1] - stemp * temp;
}
}
/* L240: */
}
}
}
}
return 0;
/* End of DLASR */
} /* dlasr_ */
}
#ifdef __cplusplus
}
}
#endif

198
lib/linalg/dlasrt.cpp
View File

@ -1,158 +1,22 @@
/* fortran/dlasrt.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASRT sorts numbers in increasing or decreasing order. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASRT + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasrt.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasrt.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasrt.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASRT( ID, N, D, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER ID */
/* INTEGER INFO, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION D( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > Sort the numbers in D in increasing order (if ID = 'I') or */
/* > in decreasing order (if ID = 'D' ). */
/* > */
/* > Use Quick Sort, reverting to Insertion sort on arrays of */
/* > size <= 20. Dimension of STACK limits N to about 2**32. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] ID */
/* > \verbatim */
/* > ID is CHARACTER*1 */
/* > = 'I': sort D in increasing order; */
/* > = 'D': sort D in decreasing order. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The length of the array D. */
/* > \endverbatim */
/* > */
/* > \param[in,out] D */
/* > \verbatim */
/* > D is DOUBLE PRECISION array, dimension (N) */
/* > On entry, the array to be sorted. */
/* > On exit, D has been sorted into increasing order */
/* > (D(1) <= ... <= D(N) ) or into decreasing order */
/* > (D(1) >= ... >= D(N) ), depending on ID. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup auxOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer *
info, ftnlen id_len)
int dlasrt_(char *id, integer *n, doublereal *d__, integer *info, ftnlen id_len)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer i__, j;
doublereal d1, d2, d3;
integer dir;
doublereal tmp;
integer endd;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer stack[64] /* was [2][32] */;
integer stack[64];
doublereal dmnmx;
integer start;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
integer stkpnt;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
/* Function Body */
*info = 0;
dir = -1;
if (lsame_(id, (char *)"D", (ftnlen)1, (ftnlen)1)) {
@ -170,13 +34,9 @@ f"> */
xerbla_((char *)"DLASRT", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n <= 1) {
return 0;
}
stkpnt = 1;
stack[0] = 1;
stack[1] = *n;
@ -185,13 +45,7 @@ L10:
endd = stack[(stkpnt << 1) - 1];
--stkpnt;
if (endd - start <= 20 && endd - start > 0) {
/* Do Insertion sort on D( START:ENDD ) */
if (dir == 0) {
/* Sort into decreasing order */
i__1 = endd;
for (i__ = start + 1; i__ <= i__1; ++i__) {
i__2 = start + 1;
@ -203,16 +57,10 @@ L10:
} else {
goto L30;
}
/* L20: */
}
L30:
;
L30:;
}
} else {
/* Sort into increasing order */
i__1 = endd;
for (i__ = start + 1; i__ <= i__1; ++i__) {
i__2 = start + 1;
@ -224,20 +72,11 @@ L30:
} else {
goto L50;
}
/* L40: */
}
L50:
;
L50:;
}
}
} else if (endd - start > 20) {
/* Partition D( START:ENDD ) and stack parts, largest one first */
/* Choose partition entry as median of 3 */
d1 = d__[start];
d2 = d__[endd];
i__ = (start + endd) / 2;
@ -259,20 +98,16 @@ L50:
dmnmx = d1;
}
}
if (dir == 0) {
/* Sort into decreasing order */
i__ = start - 1;
j = endd + 1;
L60:
L70:
L60:
L70:
--j;
if (d__[j] < dmnmx) {
goto L70;
}
L80:
L80:
++i__;
if (d__[i__] > dmnmx) {
goto L80;
@ -299,18 +134,15 @@ L80:
stack[(stkpnt << 1) - 1] = j;
}
} else {
/* Sort into increasing order */
i__ = start - 1;
j = endd + 1;
L90:
L100:
L90:
L100:
--j;
if (d__[j] > dmnmx) {
goto L100;
}
L110:
L110:
++i__;
if (d__[i__] < dmnmx) {
goto L110;
@ -342,11 +174,7 @@ L110:
goto L10;
}
return 0;
/* End of DLASRT */
} /* dlasrt_ */
}
#ifdef __cplusplus
}
}
#endif

163
lib/linalg/dlassq.cpp
View File

@ -1,165 +1,15 @@
/* fortran/dlassq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASSQ updates a sum of squares represented in scaled form. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASSQ + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlassq.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlassq.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlassq.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) */
/* .. Scalar Arguments .. */
/* INTEGER INCX, N */
/* DOUBLE PRECISION SCALE, SUMSQ */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION X( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASSQ returns the values scl and smsq such that */
/* > */
/* > ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
/* > */
/* > where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */
/* > assumed to be non-negative and scl returns the value */
/* > */
/* > scl = max( scale, abs( x( i ) ) ). */
/* > */
/* > scale and sumsq must be supplied in SCALE and SUMSQ and */
/* > scl and smsq are overwritten on SCALE and SUMSQ respectively. */
/* > */
/* > The routine makes only one pass through the vector x. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of elements to be used from the vector X. */
/* > \endverbatim */
/* > */
/* > \param[in] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION array, dimension (N) */
/* > The vector for which a scaled sum of squares is computed. */
/* > x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > The increment between successive values of the vector X. */
/* > INCX > 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] SCALE */
/* > \verbatim */
/* > SCALE is DOUBLE PRECISION */
/* > On entry, the value scale in the equation above. */
/* > On exit, SCALE is overwritten with scl , the scaling factor */
/* > for the sum of squares. */
/* > \endverbatim */
/* > */
/* > \param[in,out] SUMSQ */
/* > \verbatim */
/* > SUMSQ is DOUBLE PRECISION */
/* > On entry, the value sumsq in the equation above. */
/* > On exit, SUMSQ is overwritten with smsq , the basic sum of */
/* > squares from which scl has been factored out. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \date December 2016 */
/* > \ingroup OTHERauxiliary */
/* ===================================================================== */
/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx,
doublereal *scale, doublereal *sumsq)
int dlassq_(integer *n, doublereal *x, integer *incx, doublereal *scale, doublereal *sumsq)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
integer ix;
doublereal absxi;
extern logical disnan_(doublereal *);
/* -- LAPACK auxiliary routine (version 3.7.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* December 2016 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n > 0) {
i__1 = (*n - 1) * *incx + 1;
i__2 = *incx;
@ -167,25 +17,18 @@ f"> */
absxi = (d__1 = x[ix], abs(d__1));
if (absxi > 0. || disnan_(&absxi)) {
if (*scale < absxi) {
/* Computing 2nd power */
d__1 = *scale / absxi;
*sumsq = *sumsq * (d__1 * d__1) + 1;
*scale = absxi;
} else {
/* Computing 2nd power */
d__1 = absxi / *scale;
*sumsq += d__1 * d__1;
}
}
/* L10: */
}
}
return 0;
/* End of DLASSQ */
} /* dlassq_ */
}
#ifdef __cplusplus
}
}
#endif

242
lib/linalg/dlasv2.cpp
View File

@ -1,214 +1,25 @@
/* fortran/dlasv2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b3 = 2.;
static doublereal c_b4 = 1.;
/* > \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASV2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasv2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasv2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasv2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) */
/* .. Scalar Arguments .. */
/* DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASV2 computes the singular value decomposition of a 2-by-2 */
/* > triangular matrix */
/* > [ F G ] */
/* > [ 0 H ]. */
/* > On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */
/* > smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */
/* > right singular vectors for abs(SSMAX), giving the decomposition */
/* > */
/* > [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */
/* > [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] F */
/* > \verbatim */
/* > F is DOUBLE PRECISION */
/* > The (1,1) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] G */
/* > \verbatim */
/* > G is DOUBLE PRECISION */
/* > The (1,2) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] H */
/* > \verbatim */
/* > H is DOUBLE PRECISION */
/* > The (2,2) element of the 2-by-2 matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] SSMIN */
/* > \verbatim */
/* > SSMIN is DOUBLE PRECISION */
/* > abs(SSMIN) is the smaller singular value. */
/* > \endverbatim */
/* > */
/* > \param[out] SSMAX */
/* > \verbatim */
/* > SSMAX is DOUBLE PRECISION */
/* > abs(SSMAX) is the larger singular value. */
/* > \endverbatim */
/* > */
/* > \param[out] SNL */
/* > \verbatim */
/* > SNL is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[out] CSL */
/* > \verbatim */
/* > CSL is DOUBLE PRECISION */
/* > The vector (CSL, SNL) is a unit left singular vector for the */
/* > singular value abs(SSMAX). */
/* > \endverbatim */
/* > */
/* > \param[out] SNR */
/* > \verbatim */
/* > SNR is DOUBLE PRECISION */
/* > \endverbatim */
/* > */
/* > \param[out] CSR */
/* > \verbatim */
/* > CSR is DOUBLE PRECISION */
/* > The vector (CSR, SNR) is a unit right singular vector for the */
/* > singular value abs(SSMAX). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup OTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Any input parameter may be aliased with any output parameter. */
/* > */
/* > Barring over/underflow and assuming a guard digit in subtraction, all */
/* > output quantities are correct to within a few units in the last */
/* > place (ulps). */
/* > */
/* > In IEEE arithmetic, the code works correctly if one matrix element is */
/* > infinite. */
/* > */
/* > Overflow will not occur unless the largest singular value itself */
/* > overflows or is within a few ulps of overflow. (On machines with */
/* > partial overflow, like the Cray, overflow may occur if the largest */
/* > singular value is within a factor of 2 of overflow.) */
/* > */
/* > Underflow is harmless if underflow is gradual. Otherwise, results */
/* > may correspond to a matrix modified by perturbations of size near */
/* > the underflow threshold. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__,
doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *
csr, doublereal *snl, doublereal *csl)
int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, doublereal *ssmin, doublereal *ssmax,
doublereal *snr, doublereal *csr, doublereal *snl, doublereal *csl)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *);
/* Local variables */
doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt,
crt, slt, srt;
doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, crt, slt, srt;
integer pmax;
doublereal temp;
logical swap;
doublereal tsign;
extern doublereal dlamch_(char *, ftnlen);
logical gasmal;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
ft = *f;
fa = abs(ft);
ht = *h__;
ha = abs(*h__);
/* PMAX points to the maximum absolute element of matrix */
/* PMAX = 1 if F largest in absolute values */
/* PMAX = 2 if G largest in absolute values */
/* PMAX = 3 if H largest in absolute values */
pmax = 1;
swap = ha > fa;
if (swap) {
@ -219,16 +30,10 @@ f"> */
temp = fa;
fa = ha;
ha = temp;
/* Now FA .ge. HA */
}
gt = *g;
ga = abs(gt);
if (ga == 0.) {
/* Diagonal matrix */
*ssmin = ha;
*ssmax = fa;
clt = 1.;
@ -240,9 +45,6 @@ f"> */
if (ga > fa) {
pmax = 2;
if (fa / ga < dlamch_((char *)"EPS", (ftnlen)3)) {
/* Case of very large GA */
gasmal = FALSE_;
*ssmax = ga;
if (ha > 1.) {
@ -257,53 +59,26 @@ f"> */
}
}
if (gasmal) {
/* Normal case */
d__ = fa - ha;
if (d__ == fa) {
/* Copes with infinite F or H */
l = 1.;
} else {
l = d__ / fa;
}
/* Note that 0 .le. L .le. 1 */
m = gt / ft;
/* Note that abs(M) .le. 1/macheps */
t = 2. - l;
/* Note that T .ge. 1 */
mm = m * m;
tt = t * t;
s = sqrt(tt + mm);
/* Note that 1 .le. S .le. 1 + 1/macheps */
if (l == 0.) {
r__ = abs(m);
} else {
r__ = sqrt(l * l + mm);
}
/* Note that 0 .le. R .le. 1 + 1/macheps */
a = (s + r__) * .5;
/* Note that 1 .le. A .le. 1 + abs(M) */
*ssmin = ha / a;
*ssmax = fa * a;
if (mm == 0.) {
/* Note that M is very tiny */
if (l == 0.) {
t = d_lmp_sign(&c_b3, &ft) * d_lmp_sign(&c_b4, &gt);
} else {
@ -330,9 +105,6 @@ f"> */
*csr = crt;
*snr = srt;
}
/* Correct signs of SSMAX and SSMIN */
if (pmax == 1) {
tsign = d_lmp_sign(&c_b4, csr) * d_lmp_sign(&c_b4, csl) * d_lmp_sign(&c_b4, f);
}
@ -346,11 +118,7 @@ f"> */
d__1 = tsign * d_lmp_sign(&c_b4, f) * d_lmp_sign(&c_b4, h__);
*ssmin = d_lmp_sign(ssmin, &d__1);
return 0;
/* End of DLASV2 */
} /* dlasv2_ */
}
#ifdef __cplusplus
}
}
#endif

177
lib/linalg/dlaswp.cpp
View File

@ -1,172 +1,17 @@
/* fortran/dlaswp.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLASWP + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaswp.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaswp.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaswp.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) */
/* .. Scalar Arguments .. */
/* INTEGER INCX, K1, K2, LDA, N */
/* .. */
/* .. Array Arguments .. */
/* INTEGER IPIV( * ) */
/* DOUBLE PRECISION A( LDA, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLASWP performs a series of row interchanges on the matrix A. */
/* > One row interchange is initiated for each of rows K1 through K2 of A. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix A. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the matrix of column dimension N to which the row */
/* > interchanges will be applied. */
/* > On exit, the permuted matrix. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. */
/* > \endverbatim */
/* > */
/* > \param[in] K1 */
/* > \verbatim */
/* > K1 is INTEGER */
/* > The first element of IPIV for which a row interchange will */
/* > be done. */
/* > \endverbatim */
/* > */
/* > \param[in] K2 */
/* > \verbatim */
/* > K2 is INTEGER */
/* > (K2-K1+1) is the number of elements of IPIV for which a row */
/* > interchange will be done. */
/* > \endverbatim */
/* > */
/* > \param[in] IPIV */
/* > \verbatim */
/* > IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) */
/* > The vector of pivot indices. Only the elements in positions */
/* > K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed. */
/* > IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be */
/* > interchanged. */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > The increment between successive values of IPIV. If INCX */
/* > is negative, the pivots are applied in reverse order. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > Modified by */
/* > R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer
*k1, integer *k2, integer *ipiv, integer *incx)
int dlaswp_(integer *n, doublereal *a, integer *lda, integer *k1, integer *k2, integer *ipiv,
integer *incx)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc;
doublereal temp;
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Executable Statements .. */
/* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows */
/* K1 through K2. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
if (*incx > 0) {
ix0 = *k1;
i1 = *k1;
@ -180,7 +25,6 @@ f"> */
} else {
return 0;
}
n32 = *n / 32 << 5;
if (n32 != 0) {
i__1 = n32;
@ -188,8 +32,7 @@ f"> */
ix = ix0;
i__2 = i2;
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];
if (ip != i__) {
i__4 = j + 31;
@ -197,13 +40,10 @@ f"> */
temp = a[i__ + k * a_dim1];
a[i__ + k * a_dim1] = a[ip + k * a_dim1];
a[ip + k * a_dim1] = temp;
/* L10: */
}
}
ix += *incx;
/* L20: */
}
/* L30: */
}
}
if (n32 != *n) {
@ -219,20 +59,13 @@ f"> */
temp = a[i__ + k * a_dim1];
a[i__ + k * a_dim1] = a[ip + k * a_dim1];
a[ip + k * a_dim1] = temp;
/* L40: */
}
}
ix += *incx;
/* L50: */
}
}
return 0;
/* End of DLASWP */
} /* dlaswp_ */
}
#ifdef __cplusplus
}
}
#endif

424
lib/linalg/dlatrd.cpp
View File

@ -1,278 +1,26 @@
/* fortran/dlatrd.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static doublereal c_b5 = -1.;
static doublereal c_b6 = 1.;
static integer c__1 = 1;
static doublereal c_b16 = 0.;
/* > \brief \b DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiago
nal form by an orthogonal similarity transformation. */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DLATRD + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlatrd.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlatrd.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlatrd.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) */
/* .. Scalar Arguments .. */
/* CHARACTER UPLO */
/* INTEGER LDA, LDW, N, NB */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DLATRD reduces NB rows and columns of a real symmetric matrix A to */
/* > symmetric tridiagonal form by an orthogonal similarity */
/* > transformation Q**T * A * Q, and returns the matrices V and W which are */
/* > needed to apply the transformation to the unreduced part of A. */
/* > */
/* > If UPLO = 'U', DLATRD reduces the last NB rows and columns of a */
/* > matrix, of which the upper triangle is supplied; */
/* > if UPLO = 'L', DLATRD reduces the first NB rows and columns of a */
/* > matrix, of which the lower triangle is supplied. */
/* > */
/* > This is an auxiliary routine called by DSYTRD. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] UPLO */
/* > \verbatim */
/* > UPLO is CHARACTER*1 */
/* > Specifies whether the upper or lower triangular part of the */
/* > symmetric matrix A is stored: */
/* > = 'U': Upper triangular */
/* > = 'L': Lower triangular */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix A. */
/* > \endverbatim */
/* > */
/* > \param[in] NB */
/* > \verbatim */
/* > NB is INTEGER */
/* > The number of rows and columns to be reduced. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* > n-by-n upper triangular part of A contains the upper */
/* > triangular part of the matrix A, and the strictly lower */
/* > triangular part of A is not referenced. If UPLO = 'L', the */
/* > leading n-by-n lower triangular part of A contains the lower */
/* > triangular part of the matrix A, and the strictly upper */
/* > triangular part of A is not referenced. */
/* > On exit: */
/* > if UPLO = 'U', the last NB columns have been reduced to */
/* > tridiagonal form, with the diagonal elements overwriting */
/* > the diagonal elements of A; the elements above the diagonal */
/* > with the array TAU, represent the orthogonal matrix Q as a */
/* > product of elementary reflectors; */
/* > if UPLO = 'L', the first NB columns have been reduced to */
/* > tridiagonal form, with the diagonal elements overwriting */
/* > the diagonal elements of A; the elements below the diagonal */
/* > with the array TAU, represent the orthogonal matrix Q as a */
/* > product of elementary reflectors. */
/* > See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= (1,N). */
/* > \endverbatim */
/* > */
/* > \param[out] E */
/* > \verbatim */
/* > E is DOUBLE PRECISION array, dimension (N-1) */
/* > If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* > elements of the last NB columns of the reduced matrix; */
/* > if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* > the first NB columns of the reduced matrix. */
/* > \endverbatim */
/* > */
/* > \param[out] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (N-1) */
/* > The scalar factors of the elementary reflectors, stored in */
/* > TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* > See Further Details. */
/* > \endverbatim */
/* > */
/* > \param[out] W */
/* > \verbatim */
/* > W is DOUBLE PRECISION array, dimension (LDW,NB) */
/* > The n-by-nb matrix W required to update the unreduced part */
/* > of A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDW */
/* > \verbatim */
/* > LDW is INTEGER */
/* > The leading dimension of the array W. LDW >= max(1,N). */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERauxiliary */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* > reflectors */
/* > */
/* > Q = H(n) H(n-1) . . . H(n-nb+1). */
/* > */
/* > Each H(i) has the form */
/* > */
/* > H(i) = I - tau * v * v**T */
/* > */
/* > where tau is a real scalar, and v is a real vector with */
/* > v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* > and tau in TAU(i-1). */
/* > */
/* > If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* > reflectors */
/* > */
/* > Q = H(1) H(2) . . . H(nb). */
/* > */
/* > Each H(i) has the form */
/* > */
/* > H(i) = I - tau * v * v**T */
/* > */
/* > where tau is a real scalar, and v is a real vector with */
/* > v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
/* > and tau in TAU(i). */
/* > */
/* > The elements of the vectors v together form the n-by-nb matrix V */
/* > which is needed, with W, to apply the transformation to the unreduced */
/* > part of the matrix, using a symmetric rank-2k update of the form: */
/* > A := A - V*W**T - W*V**T. */
/* > */
/* > The contents of A on exit are illustrated by the following examples */
/* > with n = 5 and nb = 2: */
/* > */
/* > if UPLO = 'U': if UPLO = 'L': */
/* > */
/* > ( a a a v4 v5 ) ( d ) */
/* > ( a a v4 v5 ) ( 1 d ) */
/* > ( a 1 v5 ) ( v1 1 a ) */
/* > ( d 1 ) ( v1 v2 a a ) */
/* > ( d ) ( v1 v2 a a a ) */
/* > */
/* > where d denotes a diagonal element of the reduced matrix, a denotes */
/* > an element of the original matrix that is unchanged, and vi denotes */
/* > an element of the vector defining H(i). */
/* > \endverbatim */
/* > */
/* ===================================================================== */
/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
integer *ldw, ftnlen uplo_len)
int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *a, integer *lda, doublereal *e,
doublereal *tau, doublereal *w, integer *ldw, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, iw;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *),
dsymv_(char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen), dlarfg_(integer *, doublereal *, doublereal *, integer *,
doublereal *);
/* -- LAPACK auxiliary routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen),
daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *),
dsymv_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -281,165 +29,119 @@ f"> */
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = *n - i__;
dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], lda,
&w[i__ + (iw + 1) * w_dim1], ldw, &c_b6, &a[i__ * a_dim1 + 1], &c__1,
(ftnlen)12);
i__2 = *n - i__;
dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * w_dim1 + 1], ldw,
&a[i__ + (i__ + 1) * a_dim1], lda, &c_b6, &a[i__ * a_dim1 + 1], &c__1,
(ftnlen)12);
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1;
dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 +
1], &c__1, &tau[i__ - 1]);
dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + 1], &c__1,
&tau[i__ - 1]);
e[i__ - 1] = a[i__ - 1 + i__ * a_dim1];
a[i__ - 1 + i__ * a_dim1] = 1.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
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], &
c__1, (ftnlen)5);
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], &c__1, (ftnlen)5);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen)
9);
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * w_dim1 + 1], ldw,
&a[i__ * a_dim1 + 1], &c__1, &c_b16, &w[i__ + 1 + iw * w_dim1], &c__1,
(ftnlen)9);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12);
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * a_dim1 + 1], lda,
&w[i__ + 1 + iw * w_dim1], &c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1,
(ftnlen)12);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen)
9);
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * a_dim1 + 1], lda,
&a[i__ * a_dim1 + 1], &c__1, &c_b16, &w[i__ + 1 + iw * w_dim1], &c__1,
(ftnlen)9);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12);
dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * w_dim1 + 1], ldw,
&w[i__ + 1 + iw * w_dim1], &c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1,
(ftnlen)12);
}
i__2 = i__ - 1;
dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1],
&c__1, &a[i__ * a_dim1 + 1], &c__1);
alpha = tau[i__ - 1] * -.5 *
ddot_(&i__2, &w[iw * w_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * w_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
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], &
c__1, (ftnlen)12);
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], &c__1, (ftnlen)12);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
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], &
c__1, (ftnlen)12);
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], &c__1, (ftnlen)12);
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) +
i__ * a_dim1], &c__1, &tau[i__]);
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n) + i__ * a_dim1], &c__1,
&tau[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
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[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5);
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[i__ + 1 + i__ * w_dim1], &c__1,
(ftnlen)5);
i__2 = *n - i__;
i__3 = i__ - 1;
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[
i__ * w_dim1 + 1], &c__1, (ftnlen)9);
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[i__ * w_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = *n - i__;
i__3 = 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[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * w_dim1], &c__1,
(ftnlen)12);
i__2 = *n - i__;
i__3 = i__ - 1;
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[
i__ * w_dim1 + 1], &c__1, (ftnlen)9);
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[i__ * w_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = *n - i__;
i__3 = 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[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
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[i__ + 1 + i__ * w_dim1], &c__1,
(ftnlen)12);
i__2 = *n - i__;
dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ *
w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
alpha = tau[i__] * -.5 *
ddot_(&i__2, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1],
&c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[i__ + 1 + i__ * w_dim1],
&c__1);
}
/* L20: */
}
}
return 0;
/* End of DLATRD */
} /* dlatrd_ */
}
#ifdef __cplusplus
}
}
#endif

658
lib/linalg/dlatrs.cpp
View File

File diff suppressed because it is too large Load Diff

131
lib/linalg/dnrm2.cpp
View File

@ -1,130 +1,15 @@
/* fortran/dnrm2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DNRM2 */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) */
/* .. Scalar Arguments .. */
/* INTEGER INCX,N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION X(*) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DNRM2 returns the euclidean norm of a vector via the function */
/* > name, so that */
/* > */
/* > DNRM2 := sqrt( x'*x ) */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > number of elements in input vector(s) */
/* > \endverbatim */
/* > */
/* > \param[in] X */
/* > \verbatim */
/* > X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) */
/* > \endverbatim */
/* > */
/* > \param[in] INCX */
/* > \verbatim */
/* > INCX is INTEGER */
/* > storage spacing between elements of DX */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \date December 2016 */
/* > \ingroup double_blas_level1 */
/* > \par Further Details: */
/* ===================== */
/* > */
/* > \verbatim */
/* > */
/* > -- This version written on 25-October-1982. */
/* > Modified on 14-October-1993 to inline the call to DLASSQ. */
/* > Sven Hammarling, Nag Ltd. */
/* > \endverbatim */
/* > */
/* ===================================================================== */
doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer ix;
doublereal ssq, norm, scale, absxi;
/* -- Reference BLAS level1 routine (version 3.7.0) -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* December 2016 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n < 1 || *incx < 1) {
norm = 0.;
} else if (*n == 1) {
@ -132,38 +17,26 @@ doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
} else {
scale = 0.;
ssq = 1.;
/* The following loop is equivalent to this call to the LAPACK */
/* auxiliary routine: */
/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */
i__1 = (*n - 1) * *incx + 1;
i__2 = *incx;
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
if (x[ix] != 0.) {
absxi = (d__1 = x[ix], abs(d__1));
if (scale < absxi) {
/* Computing 2nd power */
d__1 = scale / absxi;
ssq = ssq * (d__1 * d__1) + 1.;
scale = absxi;
} else {
/* Computing 2nd power */
d__1 = absxi / scale;
ssq += d__1 * d__1;
}
}
/* L10: */
}
norm = scale * sqrt(ssq);
}
ret_val = norm;
return ret_val;
/* End of DNRM2. */
} /* dnrm2_ */
}
#ifdef __cplusplus
}
}
#endif

206
lib/linalg/dorg2l.cpp
View File

@ -1,186 +1,23 @@
/* fortran/dorg2l.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by s
geqlf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORG2L + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorg2l.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorg2l.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorg2l.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORG2L generates an m by n real matrix Q with orthonormal columns, */
/* > which is defined as the last n columns of a product of k elementary */
/* > reflectors of order m */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGEQLF. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix Q. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix Q. M >= N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines the */
/* > matrix Q. N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the (n-k+i)-th column must contain the vector which */
/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* > returned by DGEQLF in the last k columns of its array */
/* > argument A. */
/* > On exit, the m by n matrix Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The first dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGEQLF. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument has an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *info)
int dorg2l_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j, l, ii;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, ftnlen),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
@ -188,7 +25,7 @@ f"> */
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -5;
}
if (*info != 0) {
@ -196,57 +33,36 @@ f"> */
xerbla_((char *)"DORG2L", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.;
/* L10: */
}
a[*m - *n + j + j * a_dim1] = 1.;
/* L20: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *n - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
a[*m - *n + ii + ii * a_dim1] = 1.;
i__2 = *m - *n + ii;
i__3 = ii - 1;
dlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
a[a_offset], lda, &work[1], (ftnlen)4);
dlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &a[a_offset], lda,
&work[1], (ftnlen)4);
i__2 = *m - *n + ii - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1);
a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__];
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= i__2; ++l) {
a[l + ii * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of DORG2L */
} /* dorg2l_ */
}
#ifdef __cplusplus
}
}
#endif

207
lib/linalg/dorg2r.cpp
View File

@ -1,186 +1,23 @@
/* fortran/dorg2r.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by s
geqrf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORG2R + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorg2r.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorg2r.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorg2r.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORG2R generates an m by n real matrix Q with orthonormal columns, */
/* > which is defined as the first n columns of a product of k elementary */
/* > reflectors of order m */
/* > */
/* > Q = H(1) H(2) . . . H(k) */
/* > */
/* > as returned by DGEQRF. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix Q. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix Q. M >= N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines the */
/* > matrix Q. N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the i-th column must contain the vector which */
/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* > returned by DGEQRF in the first k columns of its array */
/* > argument A. */
/* > On exit, the m-by-n matrix Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The first dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGEQRF. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (N) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument has an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *info)
int dorg2r_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, j, l;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, ftnlen),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
@ -188,7 +25,7 @@ f"> */
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -5;
}
if (*info != 0) {
@ -196,37 +33,24 @@ f"> */
xerbla_((char *)"DORG2R", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns k+1:n to columns of the unit matrix */
i__1 = *n;
for (j = *k + 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.;
/* L10: */
}
a[j + j * a_dim1] = 1.;
/* L20: */
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i) to A(i:m,i:n) from the left */
if (i__ < *n) {
a[i__ + i__ * a_dim1] = 1.;
i__1 = *m - i__ + 1;
i__2 = *n - i__;
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], (
ftnlen)4);
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], (ftnlen)4);
}
if (i__ < *m) {
i__1 = *m - i__;
@ -234,22 +58,13 @@ f"> */
dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
}
a[i__ + i__ * a_dim1] = 1. - tau[i__];
/* Set A(1:i-1,i) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
a[l + i__ * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of DORG2R */
} /* dorg2r_ */
}
#ifdef __cplusplus
}
}
#endif

326
lib/linalg/dorgbr.cpp
View File

@ -1,404 +1,140 @@
/* fortran/dorgbr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c_n1 = -1;
/* > \brief \b DORGBR */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORGBR + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgbr.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgbr.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgbr.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER VECT */
/* INTEGER INFO, K, LDA, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORGBR generates one of the real orthogonal matrices Q or P**T */
/* > determined by DGEBRD when reducing a real matrix A to bidiagonal */
/* > form: A = Q * B * P**T. Q and P**T are defined as products of */
/* > elementary reflectors H(i) or G(i) respectively. */
/* > */
/* > If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
/* > is of order M: */
/* > if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n */
/* > columns of Q, where m >= n >= k; */
/* > if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an */
/* > M-by-M matrix. */
/* > */
/* > If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */
/* > is of order N: */
/* > if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m */
/* > rows of P**T, where n >= m >= k; */
/* > if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as */
/* > an N-by-N matrix. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] VECT */
/* > \verbatim */
/* > VECT is CHARACTER*1 */
/* > Specifies whether the matrix Q or the matrix P**T is */
/* > required, as defined in the transformation applied by DGEBRD: */
/* > = 'Q': generate Q; */
/* > = 'P': generate P**T. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix Q or P**T to be returned. */
/* > M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix Q or P**T to be returned. */
/* > N >= 0. */
/* > If VECT = 'Q', M >= N >= min(M,K); */
/* > if VECT = 'P', N >= M >= min(N,K). */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > If VECT = 'Q', the number of columns in the original M-by-K */
/* > matrix reduced by DGEBRD. */
/* > If VECT = 'P', the number of rows in the original K-by-N */
/* > matrix reduced by DGEBRD. */
/* > K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the vectors which define the elementary reflectors, */
/* > as returned by DGEBRD. */
/* > On exit, the M-by-N matrix Q or P**T. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension */
/* > (min(M,K)) if VECT = 'Q' */
/* > (min(N,K)) if VECT = 'P' */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i) or G(i), which determines Q or P**T, as */
/* > returned by DGEBRD in its array argument TAUQ or TAUP. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
/* > For optimum performance LWORK >= min(M,N)*NB, where NB */
/* > is the optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleGBcomputational */
/* ===================================================================== */
/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k,
doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *lwork, integer *info, ftnlen vect_len)
int dorgbr_(char *vect, integer *m, integer *n, integer *k, doublereal *a, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, integer *info, ftnlen vect_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, mn;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer iinfo;
logical wantq;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dorglq_(
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dorgqr_(
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *);
extern int xerbla_(char *, integer *, ftnlen),
dorglq_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *),
dorgqr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
wantq = lsame_(vect, (char *)"Q", (ftnlen)1, (ftnlen)1);
mn = min(*m,*n);
mn = min(*m, *n);
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;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
*m > *n || *m < min(*n,*k))) {
} else if (*n < 0 || wantq && (*n > *m || *n < min(*m, *k)) ||
!wantq && (*m > *n || *m < min(*n, *k))) {
*info = -3;
} else if (*k < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -6;
} else if (*lwork < max(1,mn) && ! lquery) {
} else if (*lwork < max(1, mn) && !lquery) {
*info = -9;
}
if (*info == 0) {
work[1] = 1.;
if (wantq) {
if (*m >= *k) {
dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1,
&iinfo);
dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, &iinfo);
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
i__3 = *m - 1;
dorgqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &
work[1], &c_n1, &iinfo);
dorgqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &c_n1,
&iinfo);
}
}
} else {
if (*k < *n) {
dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1,
&iinfo);
dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, &iinfo);
} else {
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
dorglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &
work[1], &c_n1, &iinfo);
dorglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &c_n1,
&iinfo);
}
}
}
lwkopt = (integer) work[1];
lwkopt = max(lwkopt,mn);
lwkopt = (integer)work[1];
lwkopt = max(lwkopt, mn);
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DORGBR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
work[1] = 1.;
return 0;
}
if (wantq) {
/* Form Q, determined by a call to DGEBRD to reduce an m-by-k */
/* matrix */
if (*m >= *k) {
/* If m >= k, assume m >= n >= k */
dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo);
} else {
/* If m < k, assume m = n */
/* Shift the vectors which define the elementary reflectors one */
/* column to the right, and set the first row and column of Q */
/* to those of the unit matrix */
for (j = *m; j >= 2; --j) {
a[j * a_dim1 + 1] = 0.;
i__1 = *m;
for (i__ = j + 1; i__ <= i__1; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
/* L10: */
}
/* L20: */
}
a[a_dim1 + 1] = 1.;
i__1 = *m;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.;
/* L30: */
}
if (*m > 1) {
/* Form Q(2:m,2:m) */
i__1 = *m - 1;
i__2 = *m - 1;
i__3 = *m - 1;
dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork,
&iinfo);
}
}
} else {
/* Form P**T, determined by a call to DGEBRD to reduce a k-by-n */
/* matrix */
if (*k < *n) {
/* If k < n, assume k <= m <= n */
dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo);
} else {
/* If k >= n, assume m = n */
/* Shift the vectors which define the elementary reflectors one */
/* row downward, and set the first row and column of P**T to */
/* those of the unit matrix */
a[a_dim1 + 1] = 1.;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.;
/* L40: */
}
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
for (i__ = j - 1; i__ >= 2; --i__) {
a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1];
/* L50: */
}
a[j * a_dim1 + 1] = 0.;
/* L60: */
}
if (*n > 1) {
/* Form P**T(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork,
&iinfo);
}
}
}
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
return 0;
/* End of DORGBR */
} /* dorgbr_ */
}
#ifdef __cplusplus
}
}
#endif

203
lib/linalg/dorgl2.cpp
View File

@ -1,180 +1,22 @@
/* fortran/dorgl2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DORGL2 */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORGL2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgl2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgl2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgl2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDA, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORGL2 generates an m by n real matrix Q with orthonormal rows, */
/* > which is defined as the first m rows of a product of k elementary */
/* > reflectors of order n */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGELQF. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix Q. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix Q. N >= M. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines the */
/* > matrix Q. M >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the i-th row must contain the vector which defines */
/* > the elementary reflector H(i), for i = 1,2,...,k, as returned */
/* > by DGELQF in the first k rows of its array argument A. */
/* > On exit, the m-by-n matrix Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The first dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGELQF. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (M) */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument has an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *info)
int dorgl2_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, j, l;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, ftnlen),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
@ -182,7 +24,7 @@ f"> */
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -5;
}
if (*info != 0) {
@ -190,65 +32,42 @@ f"> */
xerbla_((char *)"DORGL2", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = *k + 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.;
/* L10: */
}
if (j > *k && j <= *m) {
a[j + j * a_dim1] = 1.;
}
/* L20: */
}
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i) to A(i:m,i:n) from the right */
if (i__ < *n) {
if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.;
i__1 = *m - i__;
i__2 = *n - i__ + 1;
dlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (
ftnlen)5);
dlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__],
&a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)5);
}
i__1 = *n - i__;
d__1 = -tau[i__];
dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda);
}
a[i__ + i__ * a_dim1] = 1. - tau[i__];
/* Set A(i,1:i-1) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
a[i__ + l * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of DORGL2 */
} /* dorgl2_ */
}
#ifdef __cplusplus
}
}
#endif

307
lib/linalg/dorglq.cpp
View File

@ -1,215 +1,37 @@
/* fortran/dorglq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
/* > \brief \b DORGLQ */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORGLQ + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorglq.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorglq.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorglq.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDA, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORGLQ generates an M-by-N real matrix Q with orthonormal rows, */
/* > which is defined as the first M rows of a product of K elementary */
/* > reflectors of order N */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGELQF. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix Q. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix Q. N >= M. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines the */
/* > matrix Q. M >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the i-th row must contain the vector which defines */
/* > the elementary reflector H(i), for i = 1,2,...,k, as returned */
/* > by DGELQF in the first k rows of its array argument A. */
/* > On exit, the M-by-N matrix Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The first dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGELQF. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK >= max(1,M). */
/* > For optimum performance LWORK >= M*NB, where NB is */
/* > the optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument has an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
integer *info)
int dorglq_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dorgl2_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dorgl2_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
nb = ilaenv_(&c__1, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = max(1,*m) * nb;
work[1] = (doublereal) lwkopt;
lwkopt = max(1, *m) * nb;
work[1] = (doublereal)lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
@ -217,9 +39,9 @@ f"> */
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -5;
} else if (*lwork < max(1,*m) && ! lquery) {
} else if (*lwork < max(1, *m) && !lquery) {
*info = -8;
}
if (*info != 0) {
@ -229,138 +51,77 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
nx = 0;
iws = *m;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1, i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *m;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1,
(ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the last block. */
/* The first kk rows are handled by the block method. */
ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */
i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2);
/* Set A(kk+1:m,1:kk) to zero. */
kk = min(i__1, i__2);
i__1 = kk;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = kk + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the last or only block. */
if (kk < *m) {
i__1 = *m - kk;
i__2 = *n - kk;
i__3 = *k - kk;
dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo);
dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &tau[kk + 1], &work[1],
&iinfo);
}
if (kk > 0) {
/* Use blocked code */
i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3);
ib = min(i__2, i__3);
if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *n - i__ + 1;
dlarft_((char *)"Forward", (char *)"Rowwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)7);
/* Apply H**T to A(i+ib:m,i:n) from the right */
dlarft_((char *)"Forward", (char *)"Rowwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__],
&work[1], &ldwork, (ftnlen)7, (ftnlen)7);
i__2 = *m - i__ - ib + 1;
i__3 = *n - i__ + 1;
dlarfb_((char *)"Right", (char *)"Transpose", (char *)"Forward", (char *)"Rowwise", &i__2, &
i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
1], &ldwork, (ftnlen)5, (ftnlen)9, (ftnlen)7, (ftnlen)
7);
dlarfb_((char *)"Right", (char *)"Transpose", (char *)"Forward", (char *)"Rowwise", &i__2, &i__3, &ib,
&a[i__ + i__ * a_dim1], lda, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1],
lda, &work[ib + 1], &ldwork, (ftnlen)5, (ftnlen)9, (ftnlen)7, (ftnlen)7);
}
/* Apply H**T to columns i:n of current block */
i__2 = *n - i__ + 1;
dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo);
/* Set columns 1:i-1 of current block to zero */
dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo);
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + ib - 1;
for (l = i__; l <= i__3; ++l) {
a[l + j * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1] = (doublereal) iws;
work[1] = (doublereal)iws;
return 0;
/* End of DORGLQ */
} /* dorglq_ */
}
#ifdef __cplusplus
}
}
#endif

315
lib/linalg/dorgql.cpp
View File

@ -1,212 +1,33 @@
/* fortran/dorgql.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
/* > \brief \b DORGQL */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORGQL + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgql.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgql.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgql.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDA, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORGQL generates an M-by-N real matrix Q with orthonormal columns, */
/* > which is defined as the last N columns of a product of K elementary */
/* > reflectors of order M */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGEQLF. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix Q. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix Q. M >= N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines the */
/* > matrix Q. N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the (n-k+i)-th column must contain the vector which */
/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* > returned by DGEQLF in the last k columns of its array */
/* > argument A. */
/* > On exit, the M-by-N matrix Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The first dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGEQLF. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK >= max(1,N). */
/* > For optimum performance LWORK >= N*NB, where NB is the */
/* > optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument has an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
integer *info)
int dorgql_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dorg2l_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
if (*m < 0) {
@ -215,25 +36,21 @@ f"> */
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -5;
}
if (*info == 0) {
if (*n == 0) {
lwkopt = 1;
} else {
nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = *n * nb;
}
work[1] = (doublereal) lwkopt;
if (*lwork < max(1,*n) && ! lquery) {
work[1] = (doublereal)lwkopt;
if (*lwork < max(1, *n) && !lquery) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DORGQL", &i__1, (ftnlen)6);
@ -241,136 +58,74 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1, i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1,
(ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the first block. */
/* The last kk columns are handled by the block method. */
/* Computing MIN */
i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
kk = min(i__1,i__2);
/* Set A(m-kk+1:m,1:n-kk) to zero. */
kk = min(i__1, i__2);
i__1 = *n - kk;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the first or only block. */
i__1 = *m - kk;
i__2 = *n - 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) {
/* Use blocked code */
i__1 = *k;
i__2 = nb;
for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
i__2) {
/* Computing MIN */
for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
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) {
/* Form the triangular factor of the block reflector */
/* H = H(i+ib-1) . . . H(i+1) H(i) */
i__3 = *m - *k + i__ + ib - 1;
dlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k +
i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork,
(ftnlen)8, (ftnlen)10);
/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
dlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda,
&tau[i__], &work[1], &ldwork, (ftnlen)8, (ftnlen)10);
i__3 = *m - *k + i__ + ib - 1;
i__4 = *n - *k + i__ - 1;
dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", &
i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1],
lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib +
1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, (
ftnlen)10);
dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", &i__3, &i__4, &ib,
&a[(*n - *k + i__) * a_dim1 + 1], lda, &work[1], &ldwork, &a[a_offset], lda,
&work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, (ftnlen)10);
}
/* Apply H to rows 1:m-k+i+ib-1 of current block */
i__3 = *m - *k + i__ + ib - 1;
dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &
tau[i__], &work[1], &iinfo);
/* Set rows m-k+i+ib:m of current block to zero */
dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &tau[i__], &work[1],
&iinfo);
i__3 = *n - *k + i__ + ib - 1;
for (j = *n - *k + i__; j <= i__3; ++j) {
i__4 = *m;
for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
a[l + j * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1] = (doublereal) iws;
work[1] = (doublereal)iws;
return 0;
/* End of DORGQL */
} /* dorgql_ */
}
#ifdef __cplusplus
}
}
#endif

309
lib/linalg/dorgqr.cpp
View File

@ -1,216 +1,37 @@
/* fortran/dorgqr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
/* > \brief \b DORGQR */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORGQR + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgqr.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgqr.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgqr.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* INTEGER INFO, K, LDA, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORGQR generates an M-by-N real matrix Q with orthonormal columns, */
/* > which is defined as the first N columns of a product of K elementary */
/* > reflectors of order M */
/* > */
/* > Q = H(1) H(2) . . . H(k) */
/* > */
/* > as returned by DGEQRF. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix Q. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix Q. M >= N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines the */
/* > matrix Q. N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the i-th column must contain the vector which */
/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* > returned by DGEQRF in the first k columns of its array */
/* > argument A. */
/* > On exit, the M-by-N matrix Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The first dimension of the array A. LDA >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGEQRF. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK >= max(1,N). */
/* > For optimum performance LWORK >= N*NB, where NB is the */
/* > optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument has an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
integer *info)
int dorgqr_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dorg2r_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dorg2r_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = max(1,*n) * nb;
work[1] = (doublereal) lwkopt;
lwkopt = max(1, *n) * nb;
work[1] = (doublereal)lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
@ -218,9 +39,9 @@ f"> */
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
} else if (*lda < max(1, *m)) {
*info = -5;
} else if (*lwork < max(1,*n) && ! lquery) {
} else if (*lwork < max(1, *n) && !lquery) {
*info = -8;
}
if (*info != 0) {
@ -230,138 +51,78 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1, i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1,
(ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the last block. */
/* The first kk columns are handled by the block method. */
ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */
i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2);
/* Set A(1:kk,kk+1:n) to zero. */
kk = min(i__1, i__2);
i__1 = *n;
for (j = kk + 1; j <= i__1; ++j) {
i__2 = kk;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the last or only block. */
if (kk < *n) {
i__1 = *m - kk;
i__2 = *n - kk;
i__3 = *k - kk;
dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo);
dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &tau[kk + 1], &work[1],
&iinfo);
}
if (kk > 0) {
/* Use blocked code */
i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3);
ib = min(i__2, i__3);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *m - i__ + 1;
dlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)10);
/* Apply H to A(i:m,i+ib:n) from the left */
dlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__],
&work[1], &ldwork, (ftnlen)7, (ftnlen)10);
i__2 = *m - i__ + 1;
i__3 = *n - i__ - ib + 1;
dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", &
i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)
7, (ftnlen)10);
dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", &i__2, &i__3, &ib,
&a[i__ + i__ * a_dim1], lda, &work[1], &ldwork,
&a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + 1], &ldwork, (ftnlen)4,
(ftnlen)12, (ftnlen)7, (ftnlen)10);
}
/* Apply H to rows i:m of current block */
i__2 = *m - i__ + 1;
dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo);
/* Set rows 1:i-1 of current block to zero */
dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo);
i__2 = i__ + ib - 1;
for (j = i__; j <= i__2; ++j) {
i__3 = i__ - 1;
for (l = 1; l <= i__3; ++l) {
a[l + j * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1] = (doublereal) iws;
work[1] = (doublereal)iws;
return 0;
/* End of DORGQR */
} /* dorgqr_ */
}
#ifdef __cplusplus
}
}
#endif

262
lib/linalg/dorgtr.cpp
View File

@ -1,242 +1,62 @@
/* fortran/dorgtr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
/* > \brief \b DORGTR */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORGTR + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgtr.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgtr.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgtr.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER UPLO */
/* INTEGER INFO, LDA, LWORK, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORGTR generates a real orthogonal matrix Q which is defined as the */
/* > product of n-1 elementary reflectors of order N, as returned by */
/* > DSYTRD: */
/* > */
/* > if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
/* > */
/* > if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] UPLO */
/* > \verbatim */
/* > UPLO is CHARACTER*1 */
/* > = 'U': Upper triangle of A contains elementary reflectors */
/* > from DSYTRD; */
/* > = 'L': Lower triangle of A contains elementary reflectors */
/* > from DSYTRD. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The order of the matrix Q. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in,out] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,N) */
/* > On entry, the vectors which define the elementary reflectors, */
/* > as returned by DSYTRD. */
/* > On exit, the N-by-N orthogonal matrix Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (N-1) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DSYTRD. */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. LWORK >= max(1,N-1). */
/* > For optimum performance LWORK >= (N-1)*NB, where NB is */
/* > the optimal blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info,
ftnlen uplo_len)
int dorgtr_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *lwork, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, nb;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer iinfo;
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dorgql_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dorgqr_(integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *);
extern int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dorgql_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *),
dorgqr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
lquery = *lwork == -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;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
} else if (*lda < max(1, *n)) {
*info = -4;
} else /* if(complicated condition) */ {
/* Computing MAX */
} else {
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;
}
}
if (*info == 0) {
if (upper) {
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)1);
nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)1);
} else {
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)1);
nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)1);
}
/* Computing MAX */
i__1 = 1, i__2 = *n - 1;
lwkopt = max(i__1,i__2) * nb;
work[1] = (doublereal) lwkopt;
lwkopt = max(i__1, i__2) * nb;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DORGTR", &i__1, (ftnlen)6);
@ -244,88 +64,52 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (upper) {
/* Q was determined by a call to DSYTRD with UPLO = 'U' */
/* Shift the vectors which define the elementary reflectors one */
/* column to the left, and set the last row and column of Q to */
/* those of the unit matrix */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1];
/* L10: */
}
a[*n + j * a_dim1] = 0.;
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + *n * a_dim1] = 0.;
/* L30: */
}
a[*n + *n * a_dim1] = 1.;
/* Generate Q(1:n-1,1:n-1) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1],
lwork, &iinfo);
dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo);
} else {
/* Q was determined by a call to DSYTRD with UPLO = 'L'. */
/* Shift the vectors which define the elementary reflectors one */
/* column to the right, and set the first row and column of Q to */
/* those of the unit matrix */
for (j = *n; j >= 2; --j) {
a[j * a_dim1 + 1] = 0.;
i__1 = *n;
for (i__ = j + 1; i__ <= i__1; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
/* L40: */
}
/* L50: */
}
a[a_dim1 + 1] = 1.;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.;
/* L60: */
}
if (*n > 1) {
/* Generate Q(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1],
&work[1], lwork, &iinfo);
dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork,
&iinfo);
}
}
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
return 0;
/* End of DORGTR */
} /* dorgtr_ */
}
#ifdef __cplusplus
}
}
#endif

264
lib/linalg/dorm2l.cpp
View File

@ -1,230 +1,21 @@
/* fortran/dorm2l.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined
by sgeqlf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORM2L + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorm2l.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorm2l.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorm2l.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */
/* WORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER SIDE, TRANS */
/* INTEGER INFO, K, LDA, LDC, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORM2L overwrites the general real m by n matrix C with */
/* > */
/* > Q * C if SIDE = 'L' and TRANS = 'N', or */
/* > */
/* > Q**T * C if SIDE = 'L' and TRANS = 'T', or */
/* > */
/* > C * Q if SIDE = 'R' and TRANS = 'N', or */
/* > */
/* > C * Q**T if SIDE = 'R' and TRANS = 'T', */
/* > */
/* > where Q is a real orthogonal matrix defined as the product of k */
/* > elementary reflectors */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n */
/* > if SIDE = 'R'. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > = 'L': apply Q or Q**T from the Left */
/* > = 'R': apply Q or Q**T from the Right */
/* > \endverbatim */
/* > */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > = 'N': apply Q (No transpose) */
/* > = 'T': apply Q**T (Transpose) */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix C. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix C. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines */
/* > the matrix Q. */
/* > If SIDE = 'L', M >= K >= 0; */
/* > if SIDE = 'R', N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,K) */
/* > The i-th column must contain the vector which defines the */
/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* > DGEQLF in the last k columns of its array argument A. */
/* > A is modified by the routine but restored on exit. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. */
/* > If SIDE = 'L', LDA >= max(1,M); */
/* > if SIDE = 'R', LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGEQLF. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
/* > On entry, the m by n matrix C. */
/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > The leading dimension of the array C. LDC >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension */
/* > (N) if SIDE = 'L', */
/* > (M) if SIDE = 'R' */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len,
ftnlen trans_len)
int dorm2l_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a,
integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work,
integer *info, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
integer i__, i1, i2, i3, mi, ni, nq;
doublereal aii;
logical left;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen);
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
logical notran;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -233,22 +24,17 @@ f"> */
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)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;
} else if (*m < 0) {
*info = -3;
@ -256,9 +42,9 @@ f"> */
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
} else if (*lda < max(1, nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
} else if (*ldc < max(1, *m)) {
*info = -10;
}
if (*info != 0) {
@ -266,14 +52,10 @@ f"> */
xerbla_((char *)"DORM2L", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
if (left && notran || !left && !notran) {
i1 = 1;
i2 = *k;
i3 = 1;
@ -282,43 +64,27 @@ f"> */
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) is applied to C(1:m-k+i,1:n) */
mi = *m - *k + i__;
} else {
/* H(i) is applied to C(1:m,1:n-k+i) */
ni = *n - *k + i__;
}
/* Apply H(i) */
aii = a[nq - *k + i__ + i__ * a_dim1];
a[nq - *k + i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[
c_offset], ldc, &work[1], (ftnlen)1);
dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[c_offset], ldc,
&work[1], (ftnlen)1);
a[nq - *k + i__ + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DORM2L */
} /* dorm2l_ */
}
#ifdef __cplusplus
}
}
#endif

264
lib/linalg/dorm2r.cpp
View File

@ -1,230 +1,21 @@
/* fortran/dorm2r.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined
by sgeqrf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORM2R + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorm2r.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorm2r.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorm2r.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */
/* WORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER SIDE, TRANS */
/* INTEGER INFO, K, LDA, LDC, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORM2R overwrites the general real m by n matrix C with */
/* > */
/* > Q * C if SIDE = 'L' and TRANS = 'N', or */
/* > */
/* > Q**T* C if SIDE = 'L' and TRANS = 'T', or */
/* > */
/* > C * Q if SIDE = 'R' and TRANS = 'N', or */
/* > */
/* > C * Q**T if SIDE = 'R' and TRANS = 'T', */
/* > */
/* > where Q is a real orthogonal matrix defined as the product of k */
/* > elementary reflectors */
/* > */
/* > Q = H(1) H(2) . . . H(k) */
/* > */
/* > as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n */
/* > if SIDE = 'R'. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > = 'L': apply Q or Q**T from the Left */
/* > = 'R': apply Q or Q**T from the Right */
/* > \endverbatim */
/* > */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > = 'N': apply Q (No transpose) */
/* > = 'T': apply Q**T (Transpose) */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix C. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix C. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines */
/* > the matrix Q. */
/* > If SIDE = 'L', M >= K >= 0; */
/* > if SIDE = 'R', N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,K) */
/* > The i-th column must contain the vector which defines the */
/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* > DGEQRF in the first k columns of its array argument A. */
/* > A is modified by the routine but restored on exit. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. */
/* > If SIDE = 'L', LDA >= max(1,M); */
/* > if SIDE = 'R', LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGEQRF. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
/* > On entry, the m by n matrix C. */
/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > The leading dimension of the array C. LDC >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension */
/* > (N) if SIDE = 'L', */
/* > (M) if SIDE = 'R' */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len,
ftnlen trans_len)
int dorm2r_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a,
integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work,
integer *info, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
doublereal aii;
logical left;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen);
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
logical notran;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -233,22 +24,17 @@ f"> */
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)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;
} else if (*m < 0) {
*info = -3;
@ -256,9 +42,9 @@ f"> */
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
} else if (*lda < max(1, nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
} else if (*ldc < max(1, *m)) {
*info = -10;
}
if (*info != 0) {
@ -266,14 +52,10 @@ f"> */
xerbla_((char *)"DORM2R", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && ! notran || ! left && notran) {
if (left && !notran || !left && notran) {
i1 = 1;
i2 = *k;
i3 = 1;
@ -282,7 +64,6 @@ f"> */
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
jc = 1;
@ -290,39 +71,24 @@ f"> */
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H(i) is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H(i) */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
ic + jc * c_dim1], ldc, &work[1], (ftnlen)1);
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ic + jc * c_dim1],
ldc, &work[1], (ftnlen)1);
a[i__ + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DORM2R */
} /* dorm2r_ */
}
#ifdef __cplusplus
}
}
#endif

367
lib/linalg/dormbr.cpp
View File

@ -1,279 +1,36 @@
/* fortran/dormbr.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
/* > \brief \b DORMBR */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORMBR + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dormbr.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dormbr.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dormbr.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, */
/* LDC, WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER SIDE, TRANS, VECT */
/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C */
/* > with */
/* > SIDE = 'L' SIDE = 'R' */
/* > TRANS = 'N': Q * C C * Q */
/* > TRANS = 'T': Q**T * C C * Q**T */
/* > */
/* > If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C */
/* > with */
/* > SIDE = 'L' SIDE = 'R' */
/* > TRANS = 'N': P * C C * P */
/* > TRANS = 'T': P**T * C C * P**T */
/* > */
/* > Here Q and P**T are the orthogonal matrices determined by DGEBRD when */
/* > reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */
/* > P**T are defined as products of elementary reflectors H(i) and G(i) */
/* > respectively. */
/* > */
/* > Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
/* > order of the orthogonal matrix Q or P**T that is applied. */
/* > */
/* > If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
/* > if nq >= k, Q = H(1) H(2) . . . H(k); */
/* > if nq < k, Q = H(1) H(2) . . . H(nq-1). */
/* > */
/* > If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
/* > if k < nq, P = G(1) G(2) . . . G(k); */
/* > if k >= nq, P = G(1) G(2) . . . G(nq-1). */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] VECT */
/* > \verbatim */
/* > VECT is CHARACTER*1 */
/* > = 'Q': apply Q or Q**T; */
/* > = 'P': apply P or P**T. */
/* > \endverbatim */
/* > */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > = 'L': apply Q, Q**T, P or P**T from the Left; */
/* > = 'R': apply Q, Q**T, P or P**T from the Right. */
/* > \endverbatim */
/* > */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > = 'N': No transpose, apply Q or P; */
/* > = 'T': Transpose, apply Q**T or P**T. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix C. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix C. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > If VECT = 'Q', the number of columns in the original */
/* > matrix reduced by DGEBRD. */
/* > If VECT = 'P', the number of rows in the original */
/* > matrix reduced by DGEBRD. */
/* > K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension */
/* > (LDA,min(nq,K)) if VECT = 'Q' */
/* > (LDA,nq) if VECT = 'P' */
/* > The vectors which define the elementary reflectors H(i) and */
/* > G(i), whose products determine the matrices Q and P, as */
/* > returned by DGEBRD. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. */
/* > If VECT = 'Q', LDA >= max(1,nq); */
/* > if VECT = 'P', LDA >= max(1,min(nq,K)). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (min(nq,K)) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i) or G(i) which determines Q or P, as returned */
/* > by DGEBRD in the array argument TAUQ or TAUP. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
/* > On entry, the M-by-N matrix C. */
/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q */
/* > or P*C or P**T*C or C*P or C*P**T. */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > The leading dimension of the array C. LDC >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. */
/* > If SIDE = 'L', LWORK >= max(1,N); */
/* > if SIDE = 'R', LWORK >= max(1,M). */
/* > For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* > LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* > blocksize. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m,
integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
integer *info, ftnlen vect_len, ftnlen side_len, ftnlen trans_len)
int dormbr_(char *vect, char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a,
integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work,
integer *lwork, integer *info, ftnlen vect_len, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
integer i1, i2, nb, mi, ni, nq, nw;
logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer iinfo;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dormlq_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen, ftnlen);
logical notran;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
extern int dormqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen, ftnlen);
logical applyq;
char transt[1];
integer lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -282,28 +39,23 @@ f"> */
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
applyq = lsame_(vect, (char *)"Q", (ftnlen)1, (ftnlen)1);
left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
/* NQ is the order of Q or P and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = max(1,*n);
nw = max(1, *n);
} else {
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;
} else if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
} else if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*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;
} else if (*m < 0) {
*info = -4;
@ -311,64 +63,53 @@ f"> */
*info = -5;
} else if (*k < 0) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = min(nq,*k);
if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
} else {
i__1 = 1, i__2 = min(nq, *k);
if (applyq && *lda < max(1, nq) || !applyq && *lda < max(i__1, i__2)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
} else if (*ldc < max(1, *m)) {
*info = -11;
} else if (*lwork < nw && ! lquery) {
} else if (*lwork < nw && !lquery) {
*info = -13;
}
}
if (*info == 0) {
if (applyq) {
if (left) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *m - 1;
i__2 = *m - 1;
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__1, n, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2);
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__1, n, &i__2, &c_n1, (ftnlen)6, (ftnlen)2);
} else {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *n - 1;
i__2 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__1, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2);
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__1, &i__2, &c_n1, (ftnlen)6, (ftnlen)2);
}
} else {
if (left) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *m - 1;
i__2 = *m - 1;
nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2);
nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, (ftnlen)6, (ftnlen)2);
} else {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *n - 1;
i__2 = *n - 1;
nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, (
ftnlen)6, (ftnlen)2);
nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, (ftnlen)6, (ftnlen)2);
}
}
lwkopt = nw * nb;
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DORMBR", &i__1, (ftnlen)6);
@ -376,29 +117,15 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
work[1] = 1.;
if (*m == 0 || *n == 0) {
return 0;
}
if (applyq) {
/* Apply Q */
if (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__[
c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (
ftnlen)1);
dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1],
lwork, &iinfo, (ftnlen)1, (ftnlen)1);
} else if (nq > 1) {
/* Q was determined by a call to DGEBRD with nq < k */
if (left) {
mi = *m - 1;
ni = *n;
@ -411,30 +138,19 @@ f"> */
i2 = 2;
}
i__1 = nq - 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, (
ftnlen)1, (ftnlen)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, (ftnlen)1, (ftnlen)1);
}
} else {
/* Apply P */
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
if (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__[
c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (
ftnlen)1);
dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc,
&work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1);
} else if (nq > 1) {
/* P was determined by a call to DGEBRD with nq <= k */
if (left) {
mi = *m - 1;
ni = *n;
@ -447,18 +163,13 @@ f"> */
i2 = 2;
}
i__1 = nq - 1;
dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
&tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
iinfo, (ftnlen)1, (ftnlen)1);
dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, &tau[1],
&c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1);
}
}
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
return 0;
/* End of DORMBR */
} /* dormbr_ */
}
#ifdef __cplusplus
}
}
#endif

261
lib/linalg/dorml2.cpp
View File

@ -1,226 +1,20 @@
/* fortran/dorml2.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* > \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined
by sgelqf (unblocked algorithm). */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORML2 + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorml2.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorml2.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorml2.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */
/* WORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER SIDE, TRANS */
/* INTEGER INFO, K, LDA, LDC, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORML2 overwrites the general real m by n matrix C with */
/* > */
/* > Q * C if SIDE = 'L' and TRANS = 'N', or */
/* > */
/* > Q**T* C if SIDE = 'L' and TRANS = 'T', or */
/* > */
/* > C * Q if SIDE = 'R' and TRANS = 'N', or */
/* > */
/* > C * Q**T if SIDE = 'R' and TRANS = 'T', */
/* > */
/* > where Q is a real orthogonal matrix defined as the product of k */
/* > elementary reflectors */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n */
/* > if SIDE = 'R'. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > = 'L': apply Q or Q**T from the Left */
/* > = 'R': apply Q or Q**T from the Right */
/* > \endverbatim */
/* > */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > = 'N': apply Q (No transpose) */
/* > = 'T': apply Q**T (Transpose) */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix C. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix C. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines */
/* > the matrix Q. */
/* > If SIDE = 'L', M >= K >= 0; */
/* > if SIDE = 'R', N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension */
/* > (LDA,M) if SIDE = 'L', */
/* > (LDA,N) if SIDE = 'R' */
/* > The i-th row must contain the vector which defines the */
/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* > DGELQF in the first k rows of its array argument A. */
/* > A is modified by the routine but restored on exit. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,K). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGELQF. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
/* > On entry, the m by n matrix C. */
/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > The leading dimension of the array C. LDC >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension */
/* > (N) if SIDE = 'L', */
/* > (M) if SIDE = 'R' */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len,
ftnlen trans_len)
int dorml2_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a,
integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work,
integer *info, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
doublereal aii;
logical left;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen);
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
logical notran;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -229,22 +23,17 @@ f"> */
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)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;
} else if (*m < 0) {
*info = -3;
@ -252,9 +41,9 @@ f"> */
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,*k)) {
} else if (*lda < max(1, *k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
} else if (*ldc < max(1, *m)) {
*info = -10;
}
if (*info != 0) {
@ -262,14 +51,10 @@ f"> */
xerbla_((char *)"DORML2", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
if (left && notran || !left && !notran) {
i1 = 1;
i2 = *k;
i3 = 1;
@ -278,7 +63,6 @@ f"> */
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
jc = 1;
@ -286,39 +70,24 @@ f"> */
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H(i) is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H(i) */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[
ic + jc * c_dim1], ldc, &work[1], (ftnlen)1);
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ic + jc * c_dim1], ldc,
&work[1], (ftnlen)1);
a[i__ + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DORML2 */
} /* dorml2_ */
}
#ifdef __cplusplus
}
}
#endif

348
lib/linalg/dormlq.cpp
View File

@ -1,257 +1,39 @@
/* fortran/dormlq.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__65 = 65;
/* > \brief \b DORMLQ */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORMLQ + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dormlq.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dormlq.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dormlq.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */
/* WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER SIDE, TRANS */
/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORMLQ overwrites the general real M-by-N matrix C with */
/* > */
/* > SIDE = 'L' SIDE = 'R' */
/* > TRANS = 'N': Q * C C * Q */
/* > TRANS = 'T': Q**T * C C * Q**T */
/* > */
/* > where Q is a real orthogonal matrix defined as the product of k */
/* > elementary reflectors */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N */
/* > if SIDE = 'R'. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > = 'L': apply Q or Q**T from the Left; */
/* > = 'R': apply Q or Q**T from the Right. */
/* > \endverbatim */
/* > */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > = 'N': No transpose, apply Q; */
/* > = 'T': Transpose, apply Q**T. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix C. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix C. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines */
/* > the matrix Q. */
/* > If SIDE = 'L', M >= K >= 0; */
/* > if SIDE = 'R', N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension */
/* > (LDA,M) if SIDE = 'L', */
/* > (LDA,N) if SIDE = 'R' */
/* > The i-th row must contain the vector which defines the */
/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* > DGELQF in the first k rows of its array argument A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. LDA >= max(1,K). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGELQF. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
/* > On entry, the M-by-N matrix C. */
/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > The leading dimension of the array C. LDC >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. */
/* > If SIDE = 'L', LWORK >= max(1,N); */
/* > if SIDE = 'R', LWORK >= max(1,M). */
/* > For good performance, LWORK should generally be larger. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info,
ftnlen side_len, ftnlen trans_len)
int dormlq_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a,
integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work,
integer *lwork, integer *info, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
integer i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt;
logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nbmin, iinfo;
extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char
*, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dorml2_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen,
ftnlen),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
logical notran;
integer ldwork;
char transt[1];
integer lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -260,25 +42,20 @@ f"> */
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = max(1,*n);
nw = max(1, *n);
} else {
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;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
} else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*m < 0) {
*info = -3;
@ -286,30 +63,22 @@ f"> */
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,*k)) {
} else if (*lda < max(1, *k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
} else if (*ldc < max(1, *m)) {
*info = -10;
} else if (*lwork < nw && ! lquery) {
} else if (*lwork < nw && !lquery) {
*info = -12;
}
if (*info == 0) {
/* Compute the workspace requirements */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_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, (
ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2);
i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2);
nb = min(i__1, i__2);
lwkopt = nw * nb + 4160;
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DORMLQ", &i__1, (ftnlen)6);
@ -317,42 +86,28 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
if (*lwork < lwkopt) {
nb = (*lwork - 4160) / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_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, (
ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2);
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2);
nbmin = max(i__1, i__2);
}
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1);
dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1],
&iinfo, (ftnlen)1, (ftnlen)1);
} else {
/* Use blocked code */
iwt = nw * nb + 1;
if (left && notran || ! left && ! notran) {
if (left && notran || !left && !notran) {
i1 = 1;
i2 = *k;
i3 = nb;
@ -361,7 +116,6 @@ f"> */
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
@ -369,56 +123,34 @@ f"> */
mi = *m;
ic = 1;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
ib = min(i__4, i__5);
i__4 = nq - i__ + 1;
dlarft_((char *)"Forward", (char *)"Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, (ftnlen)7);
dlarft_((char *)"Forward", (char *)"Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__],
&work[iwt], &c__65, (ftnlen)7, (ftnlen)7);
if (left) {
/* H or H**T is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H**T is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H**T */
dlarfb_(side, transt, (char *)"Forward", (char *)"Rowwise", &mi, &ni, &ib, &a[i__
+ i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc *
c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (
ftnlen)7, (ftnlen)7);
/* L10: */
dlarfb_(side, transt, (char *)"Forward", (char *)"Rowwise", &mi, &ni, &ib, &a[i__ + i__ * a_dim1], lda,
&work[iwt], &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1,
(ftnlen)1, (ftnlen)7, (ftnlen)7);
}
}
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
return 0;
/* End of DORMLQ */
} /* dormlq_ */
}
#ifdef __cplusplus
}
}
#endif

348
lib/linalg/dormql.cpp
View File

@ -1,255 +1,37 @@
/* fortran/dormql.f -- translated by f2c (version 20200916).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
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
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__65 = 65;
/* > \brief \b DORMQL */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* > \htmlonly */
/* > Download DORMQL + dependencies */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dormql.
f"> */
/* > [TGZ]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dormql.
f"> */
/* > [ZIP]</a> */
/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dormql.
f"> */
/* > [TXT]</a> */
/* > \endhtmlonly */
/* Definition: */
/* =========== */
/* SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */
/* WORK, LWORK, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER SIDE, TRANS */
/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */
/* .. */
/* .. Array Arguments .. */
/* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > DORMQL overwrites the general real M-by-N matrix C with */
/* > */
/* > SIDE = 'L' SIDE = 'R' */
/* > TRANS = 'N': Q * C C * Q */
/* > TRANS = 'T': Q**T * C C * Q**T */
/* > */
/* > where Q is a real orthogonal matrix defined as the product of k */
/* > elementary reflectors */
/* > */
/* > Q = H(k) . . . H(2) H(1) */
/* > */
/* > as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N */
/* > if SIDE = 'R'. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SIDE */
/* > \verbatim */
/* > SIDE is CHARACTER*1 */
/* > = 'L': apply Q or Q**T from the Left; */
/* > = 'R': apply Q or Q**T from the Right. */
/* > \endverbatim */
/* > */
/* > \param[in] TRANS */
/* > \verbatim */
/* > TRANS is CHARACTER*1 */
/* > = 'N': No transpose, apply Q; */
/* > = 'T': Transpose, apply Q**T. */
/* > \endverbatim */
/* > */
/* > \param[in] M */
/* > \verbatim */
/* > M is INTEGER */
/* > The number of rows of the matrix C. M >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] N */
/* > \verbatim */
/* > N is INTEGER */
/* > The number of columns of the matrix C. N >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] K */
/* > \verbatim */
/* > K is INTEGER */
/* > The number of elementary reflectors whose product defines */
/* > the matrix Q. */
/* > If SIDE = 'L', M >= K >= 0; */
/* > if SIDE = 'R', N >= K >= 0. */
/* > \endverbatim */
/* > */
/* > \param[in] A */
/* > \verbatim */
/* > A is DOUBLE PRECISION array, dimension (LDA,K) */
/* > The i-th column must contain the vector which defines the */
/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* > DGEQLF in the last k columns of its array argument A. */
/* > \endverbatim */
/* > */
/* > \param[in] LDA */
/* > \verbatim */
/* > LDA is INTEGER */
/* > The leading dimension of the array A. */
/* > If SIDE = 'L', LDA >= max(1,M); */
/* > if SIDE = 'R', LDA >= max(1,N). */
/* > \endverbatim */
/* > */
/* > \param[in] TAU */
/* > \verbatim */
/* > TAU is DOUBLE PRECISION array, dimension (K) */
/* > TAU(i) must contain the scalar factor of the elementary */
/* > reflector H(i), as returned by DGEQLF. */
/* > \endverbatim */
/* > */
/* > \param[in,out] C */
/* > \verbatim */
/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
/* > On entry, the M-by-N matrix C. */
/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
/* > \endverbatim */
/* > */
/* > \param[in] LDC */
/* > \verbatim */
/* > LDC is INTEGER */
/* > The leading dimension of the array C. LDC >= max(1,M). */
/* > \endverbatim */
/* > */
/* > \param[out] WORK */
/* > \verbatim */
/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* > \endverbatim */
/* > */
/* > \param[in] LWORK */
/* > \verbatim */
/* > LWORK is INTEGER */
/* > The dimension of the array WORK. */
/* > If SIDE = 'L', LWORK >= max(1,N); */
/* > if SIDE = 'R', LWORK >= max(1,M). */
/* > For good performance, LWORK should generally be larger. */
/* > */
/* > If LWORK = -1, then a workspace query is assumed; the routine */
/* > only calculates the optimal size of the WORK array, returns */
/* > this value as the first entry of the WORK array, and no error */
/* > message related to LWORK is issued by XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[out] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > = 0: successful exit */
/* > < 0: if INFO = -i, the i-th argument had an illegal value */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \ingroup doubleOTHERcomputational */
/* ===================================================================== */
/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info,
ftnlen side_len, ftnlen trans_len)
int dormql_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a,
integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work,
integer *lwork, integer *info, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
integer i__, i1, i2, i3, ib, nb, mi, ni, nq, nw, iwt;
logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nbmin, iinfo;
extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char
*, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern int dorm2l_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen,
ftnlen),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
logical notran;
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK computational routine -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
@ -258,25 +40,20 @@ f"> */
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = max(1,*n);
nw = max(1, *n);
} else {
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;
} else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
} else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*m < 0) {
*info = -3;
@ -284,34 +61,26 @@ f"> */
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
} else if (*lda < max(1, nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
} else if (*ldc < max(1, *m)) {
*info = -10;
} else if (*lwork < nw && ! lquery) {
} else if (*lwork < nw && !lquery) {
*info = -12;
}
if (*info == 0) {
/* Compute the workspace requirements */
if (*m == 0 || *n == 0) {
lwkopt = 1;
} else {
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_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,
(ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2);
i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2);
nb = min(i__1, i__2);
lwkopt = nw * nb + 4160;
}
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DORMQL", &i__1, (ftnlen)6);
@ -319,41 +88,27 @@ f"> */
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
if (*lwork < lwkopt) {
nb = (*lwork - 4160) / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_lmp_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, (
ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2);
i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQL", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2);
nbmin = max(i__1, i__2);
}
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1);
dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1],
&iinfo, (ftnlen)1, (ftnlen)1);
} else {
/* Use blocked code */
iwt = nw * nb + 1;
if (left && notran || ! left && ! notran) {
if (left && notran || !left && !notran) {
i1 = 1;
i2 = *k;
i3 = nb;
@ -362,55 +117,32 @@ f"> */
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i+ib-1) . . . H(i+1) H(i) */
ib = min(i__4, i__5);
i__4 = nq - *k + i__ + ib - 1;
dlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
, lda, &tau[i__], &work[iwt], &c__65, (ftnlen)8, (ftnlen)
10);
dlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__],
&work[iwt], &c__65, (ftnlen)8, (ftnlen)10);
if (left) {
/* H or H**T is applied to C(1:m-k+i+ib-1,1:n) */
mi = *m - *k + i__ + ib - 1;
} else {
/* H or H**T is applied to C(1:m,1:n-k+i+ib-1) */
ni = *n - *k + i__ + ib - 1;
}
/* Apply H or H**T */
dlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[
i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset]
, ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (ftnlen)8,
(ftnlen)10);
/* L10: */
dlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[i__ * a_dim1 + 1], lda,
&work[iwt], &c__65, &c__[c_offset], ldc, &work[1], &ldwork, (ftnlen)1,
(ftnlen)1, (ftnlen)8, (ftnlen)10);
}
}
work[1] = (doublereal) lwkopt;
work[1] = (doublereal)lwkopt;
return 0;
/* End of DORMQL */
} /* dormql_ */
}
#ifdef __cplusplus
}
}
#endif

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