vendor: OpenCV 5.0.0 snapshot at 40738fb16ceddb5fb3fea747585f7ce6abb0605b
This commit is contained in:
Gitea Mirror Bot
Vendored
+752
@@ -0,0 +1,752 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b CGEMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// COMPLEX ALPHA,BETA
|
||||
// INTEGER K,LDA,LDB,LDC,M,N
|
||||
// CHARACTER TRANSA,TRANSB
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> CGEMM 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 or op( X ) = X**H,
|
||||
//>
|
||||
//> 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**H.
|
||||
//> \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**H.
|
||||
//> \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 COMPLEX
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is COMPLEX 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 COMPLEX 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 COMPLEX
|
||||
//> 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 COMPLEX 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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup complex_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 cgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, complex *alpha, complex *a, int *lda, complex *b, int *ldb,
|
||||
complex *beta, complex *c__, int *ldc)
|
||||
{
|
||||
// Table of constant values
|
||||
complex c_b1 = {1.f,0.f};
|
||||
complex c_b2 = {0.f,0.f};
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
|
||||
i__3, i__4, i__5, i__6;
|
||||
complex q__1, q__2, q__3, q__4;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
complex temp;
|
||||
int conja, conjb;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 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 ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
//
|
||||
// Set NOTA and NOTB as true if A and B respectively are not
|
||||
// conjugated or transposed, set CONJA and CONJB as true if A and
|
||||
// B respectively are to be transposed but not conjugated and set
|
||||
// NROWA, NCOLA and NROWB as the number of rows and columns of A
|
||||
// and the number of rows of B respectively.
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
b_dim1 = *ldb;
|
||||
b_offset = 1 + b_dim1;
|
||||
b -= b_offset;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
|
||||
// Function Body
|
||||
nota = lsame_(transa, "N");
|
||||
notb = lsame_(transb, "N");
|
||||
conja = lsame_(transa, "C");
|
||||
conjb = lsame_(transb, "C");
|
||||
if (nota) {
|
||||
nrowa = *m;
|
||||
ncola = *k;
|
||||
} else {
|
||||
nrowa = *k;
|
||||
ncola = *m;
|
||||
}
|
||||
if (notb) {
|
||||
nrowb = *k;
|
||||
} else {
|
||||
nrowb = *n;
|
||||
}
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
info = 0;
|
||||
if (! nota && ! conja && ! lsame_(transa, "T")) {
|
||||
info = 1;
|
||||
} else if (! notb && ! conjb && ! lsame_(transb, "T")) {
|
||||
info = 2;
|
||||
} else if (*m < 0) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < max(1,nrowa)) {
|
||||
info = 8;
|
||||
} else if (*ldb < max(1,nrowb)) {
|
||||
info = 10;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
info = 13;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("CGEMM ", &info);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible.
|
||||
//
|
||||
if (*m == 0 || *n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0)
|
||||
&& (beta->r == 1.f && beta->i == 0.f)) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// And when alpha.eq.zero.
|
||||
//
|
||||
if (alpha->r == 0.f && alpha->i == 0.f) {
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0.f, c__[i__3].i = 0.f;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
|
||||
q__1.i = beta->r * c__[i__4].i + beta->i * c__[
|
||||
i__4].r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
// 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->r == 0.f && beta->i == 0.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0.f, c__[i__3].i = 0.f;
|
||||
// L50:
|
||||
}
|
||||
} else if (beta->r != 1.f || beta->i != 0.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__1.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
// L60:
|
||||
}
|
||||
}
|
||||
i__2 = *k;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
i__3 = l + j * b_dim1;
|
||||
q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
|
||||
q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
|
||||
.r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__ + j * c_dim1;
|
||||
i__5 = i__ + j * c_dim1;
|
||||
i__6 = i__ + l * a_dim1;
|
||||
q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
|
||||
q__2.i = temp.r * a[i__6].i + temp.i * a[i__6]
|
||||
.r;
|
||||
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
|
||||
q__2.i;
|
||||
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
|
||||
// L70:
|
||||
}
|
||||
// L80:
|
||||
}
|
||||
// L90:
|
||||
}
|
||||
} else if (conja) {
|
||||
//
|
||||
// Form C := alpha*A**H*B + beta*C.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0.f, temp.i = 0.f;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
r_cnjg(&q__3, &a[l + i__ * a_dim1]);
|
||||
i__4 = l + j * b_dim1;
|
||||
q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
|
||||
q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
|
||||
.r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
// L100:
|
||||
}
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
}
|
||||
// L110:
|
||||
}
|
||||
// L120:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A**T*B + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0.f, temp.i = 0.f;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
i__4 = l + i__ * a_dim1;
|
||||
i__5 = l + j * b_dim1;
|
||||
q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
|
||||
.i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
|
||||
.i * b[i__5].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
// L130:
|
||||
}
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
}
|
||||
// L140:
|
||||
}
|
||||
// L150:
|
||||
}
|
||||
}
|
||||
} else if (nota) {
|
||||
if (conjb) {
|
||||
//
|
||||
// Form C := alpha*A*B**H + beta*C.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0.f, c__[i__3].i = 0.f;
|
||||
// L160:
|
||||
}
|
||||
} else if (beta->r != 1.f || beta->i != 0.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__1.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
// L170:
|
||||
}
|
||||
}
|
||||
i__2 = *k;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
r_cnjg(&q__2, &b[j + l * b_dim1]);
|
||||
q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
|
||||
alpha->r * q__2.i + alpha->i * q__2.r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__ + j * c_dim1;
|
||||
i__5 = i__ + j * c_dim1;
|
||||
i__6 = i__ + l * a_dim1;
|
||||
q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
|
||||
q__2.i = temp.r * a[i__6].i + temp.i * a[i__6]
|
||||
.r;
|
||||
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
|
||||
q__2.i;
|
||||
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
|
||||
// L180:
|
||||
}
|
||||
// L190:
|
||||
}
|
||||
// L200:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A*B**T + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0.f, c__[i__3].i = 0.f;
|
||||
// L210:
|
||||
}
|
||||
} else if (beta->r != 1.f || beta->i != 0.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__1.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
// L220:
|
||||
}
|
||||
}
|
||||
i__2 = *k;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
i__3 = j + l * b_dim1;
|
||||
q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
|
||||
q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
|
||||
.r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__ + j * c_dim1;
|
||||
i__5 = i__ + j * c_dim1;
|
||||
i__6 = i__ + l * a_dim1;
|
||||
q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
|
||||
q__2.i = temp.r * a[i__6].i + temp.i * a[i__6]
|
||||
.r;
|
||||
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
|
||||
q__2.i;
|
||||
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
|
||||
// L230:
|
||||
}
|
||||
// L240:
|
||||
}
|
||||
// L250:
|
||||
}
|
||||
}
|
||||
} else if (conja) {
|
||||
if (conjb) {
|
||||
//
|
||||
// Form C := alpha*A**H*B**H + beta*C.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0.f, temp.i = 0.f;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
r_cnjg(&q__3, &a[l + i__ * a_dim1]);
|
||||
r_cnjg(&q__4, &b[j + l * b_dim1]);
|
||||
q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, q__2.i =
|
||||
q__3.r * q__4.i + q__3.i * q__4.r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
// L260:
|
||||
}
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
}
|
||||
// L270:
|
||||
}
|
||||
// L280:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A**H*B**T + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0.f, temp.i = 0.f;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
r_cnjg(&q__3, &a[l + i__ * a_dim1]);
|
||||
i__4 = j + l * b_dim1;
|
||||
q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
|
||||
q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
|
||||
.r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
// L290:
|
||||
}
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
}
|
||||
// L300:
|
||||
}
|
||||
// L310:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (conjb) {
|
||||
//
|
||||
// Form C := alpha*A**T*B**H + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0.f, temp.i = 0.f;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
i__4 = l + i__ * a_dim1;
|
||||
r_cnjg(&q__3, &b[j + l * b_dim1]);
|
||||
q__2.r = a[i__4].r * q__3.r - a[i__4].i * q__3.i,
|
||||
q__2.i = a[i__4].r * q__3.i + a[i__4].i *
|
||||
q__3.r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
// L320:
|
||||
}
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
}
|
||||
// L330:
|
||||
}
|
||||
// L340:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A**T*B**T + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0.f, temp.i = 0.f;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
i__4 = l + i__ * a_dim1;
|
||||
i__5 = j + l * b_dim1;
|
||||
q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
|
||||
.i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
|
||||
.i * b[i__5].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
// L350:
|
||||
}
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
q__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
q__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
|
||||
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
|
||||
}
|
||||
// L360:
|
||||
}
|
||||
// L370:
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of CGEMM .
|
||||
//
|
||||
} // cgemm_
|
||||
|
||||
Vendored
+171
@@ -0,0 +1,171 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \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_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, m, ix, iy, mp1;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. 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;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dy[i__] = dx[i__];
|
||||
}
|
||||
if (*n < 7) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
mp1 = m + 1;
|
||||
i__1 = *n;
|
||||
for (i__ = mp1; i__ <= i__1; i__ += 7) {
|
||||
dy[i__] = dx[i__];
|
||||
dy[i__ + 1] = dx[i__ + 1];
|
||||
dy[i__ + 2] = dx[i__ + 2];
|
||||
dy[i__ + 3] = dx[i__ + 3];
|
||||
dy[i__ + 4] = dx[i__ + 4];
|
||||
dy[i__ + 5] = dx[i__ + 5];
|
||||
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) {
|
||||
ix = (-(*n) + 1) * *incx + 1;
|
||||
}
|
||||
if (*incy < 0) {
|
||||
iy = (-(*n) + 1) * *incy + 1;
|
||||
}
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dy[iy] = dx[ix];
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // dcopy_
|
||||
|
||||
Vendored
+172
@@ -0,0 +1,172 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \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
|
||||
//>
|
||||
// =====================================================================
|
||||
double ddot_(int *n, double *dx, int *incx, double *dy, int *incy)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
double ret_val;
|
||||
|
||||
// Local variables
|
||||
int i__, m, ix, iy, mp1;
|
||||
double dtemp;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. 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;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp += dx[i__] * dy[i__];
|
||||
}
|
||||
if (*n < 5) {
|
||||
ret_val = dtemp;
|
||||
return ret_val;
|
||||
}
|
||||
}
|
||||
mp1 = m + 1;
|
||||
i__1 = *n;
|
||||
for (i__ = mp1; i__ <= i__1; i__ += 5) {
|
||||
dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] +
|
||||
dx[i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] +
|
||||
dx[i__ + 4] * dy[i__ + 4];
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// code for unequal increments or equal increments
|
||||
// not equal to 1
|
||||
//
|
||||
ix = 1;
|
||||
iy = 1;
|
||||
if (*incx < 0) {
|
||||
ix = (-(*n) + 1) * *incx + 1;
|
||||
}
|
||||
if (*incy < 0) {
|
||||
iy = (-(*n) + 1) * *incy + 1;
|
||||
}
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp += dx[ix] * dy[iy];
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
}
|
||||
}
|
||||
ret_val = dtemp;
|
||||
return ret_val;
|
||||
} // ddot_
|
||||
|
||||
Vendored
+14369
File diff suppressed because it is too large
Load Diff
Vendored
+444
@@ -0,0 +1,444 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \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, int *m, int *n, int *
|
||||
k, double *alpha, double *a, int *lda, double *b, int *ldb, double *
|
||||
beta, double *c__, int *ldc)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
|
||||
i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
double temp;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 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 ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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, NCOLA and NROWB as the number of rows
|
||||
// and columns of A and the number of rows of B respectively.
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
b_dim1 = *ldb;
|
||||
b_offset = 1 + b_dim1;
|
||||
b -= b_offset;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
|
||||
// Function Body
|
||||
nota = lsame_(transa, "N");
|
||||
notb = lsame_(transb, "N");
|
||||
if (nota) {
|
||||
nrowa = *m;
|
||||
ncola = *k;
|
||||
} else {
|
||||
nrowa = *k;
|
||||
ncola = *m;
|
||||
}
|
||||
if (notb) {
|
||||
nrowb = *k;
|
||||
} else {
|
||||
nrowb = *n;
|
||||
}
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
info = 0;
|
||||
if (! nota && ! lsame_(transa, "C") && ! lsame_(transa, "T")) {
|
||||
info = 1;
|
||||
} else if (! notb && ! lsame_(transb, "C") && ! lsame_(transb, "T")) {
|
||||
info = 2;
|
||||
} else if (*m < 0) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < max(1,nrowa)) {
|
||||
info = 8;
|
||||
} else if (*ldb < max(1,nrowb)) {
|
||||
info = 10;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
info = 13;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DGEMM ", &info);
|
||||
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;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] = 0.;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
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;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
temp = *alpha * b[l + j * b_dim1];
|
||||
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;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp = 0.;
|
||||
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];
|
||||
}
|
||||
// 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;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
temp = *alpha * b[j + l * b_dim1];
|
||||
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;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp = 0.;
|
||||
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];
|
||||
}
|
||||
// L190:
|
||||
}
|
||||
// L200:
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DGEMM .
|
||||
//
|
||||
} // dgemm_
|
||||
|
||||
Vendored
+370
@@ -0,0 +1,370 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \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, int *m, int *n, double *alpha,
|
||||
double *a, int *lda, double *x, int *incx, double *beta, double *y,
|
||||
int *incy)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j, ix, iy, jx, jy, kx, ky, info;
|
||||
double temp;
|
||||
int lenx, leny;
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level2 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 ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
--y;
|
||||
|
||||
// Function Body
|
||||
info = 0;
|
||||
if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
|
||||
{
|
||||
info = 1;
|
||||
} else if (*m < 0) {
|
||||
info = 2;
|
||||
} else if (*n < 0) {
|
||||
info = 3;
|
||||
} else if (*lda < max(1,*m)) {
|
||||
info = 6;
|
||||
} else if (*incx == 0) {
|
||||
info = 8;
|
||||
} else if (*incy == 0) {
|
||||
info = 11;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DGEMV ", &info);
|
||||
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, "N")) {
|
||||
lenx = *n;
|
||||
leny = *m;
|
||||
} else {
|
||||
lenx = *m;
|
||||
leny = *n;
|
||||
}
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (lenx - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} 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 {
|
||||
iy = ky;
|
||||
if (*beta == 0.) {
|
||||
i__1 = leny;
|
||||
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:
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (*alpha == 0.) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(trans, "N")) {
|
||||
//
|
||||
// Form y := alpha*A*x + y.
|
||||
//
|
||||
jx = kx;
|
||||
if (*incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp = *alpha * x[jx];
|
||||
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;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp = *alpha * x[jx];
|
||||
iy = ky;
|
||||
i__2 = *m;
|
||||
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;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp = 0.;
|
||||
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;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp = 0.;
|
||||
ix = kx;
|
||||
i__2 = *m;
|
||||
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_
|
||||
|
||||
Vendored
+18599
File diff suppressed because it is too large
Load Diff
Vendored
+186
@@ -0,0 +1,186 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DISNAN tests input for NaN.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DISNAN + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/disnan.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/disnan.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/disnan.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// LOGICAL FUNCTION DISNAN( DIN )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION, INTENT(IN) :: DIN
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
|
||||
//> otherwise. To be replaced by the Fortran 2003 intrinsic in the
|
||||
//> future.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] DIN
|
||||
//> \verbatim
|
||||
//> DIN is DOUBLE PRECISION
|
||||
//> Input to test for NaN.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2017
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int disnan_(double *din)
|
||||
{
|
||||
// System generated locals
|
||||
int ret_val;
|
||||
|
||||
// Local variables
|
||||
extern int dlaisnan_(double *, double *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.1) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
ret_val = dlaisnan_(din, din);
|
||||
return ret_val;
|
||||
} // disnan_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLAISNAN + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaisnan.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaisnan.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaisnan.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> This routine is not for general use. It exists solely to avoid
|
||||
//> over-optimization in DISNAN.
|
||||
//>
|
||||
//> DLAISNAN checks for NaNs by comparing its two arguments for
|
||||
//> inequality. NaN is the only floating-point value where NaN != NaN
|
||||
//> returns .TRUE. To check for NaNs, pass the same variable as both
|
||||
//> arguments.
|
||||
//>
|
||||
//> A compiler must assume that the two arguments are
|
||||
//> not the same variable, and the test will not be optimized away.
|
||||
//> Interprocedural or whole-program optimization may delete this
|
||||
//> test. The ISNAN functions will be replaced by the correct
|
||||
//> Fortran 03 intrinsic once the intrinsic is widely available.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] DIN1
|
||||
//> \verbatim
|
||||
//> DIN1 is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DIN2
|
||||
//> \verbatim
|
||||
//> DIN2 is DOUBLE PRECISION
|
||||
//> Two numbers to compare for inequality.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2017
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int dlaisnan_(double *din1, double *din2)
|
||||
{
|
||||
// System generated locals
|
||||
int ret_val;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.1) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Executable Statements ..
|
||||
ret_val = *din1 != *din2;
|
||||
return ret_val;
|
||||
} // dlaisnan_
|
||||
|
||||
Vendored
+184
@@ -0,0 +1,184 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlacpy_(char *uplo, int *m, int *n, double *a, int *lda,
|
||||
double *b, int *ldb)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
extern int lsame_(char *, char *);
|
||||
|
||||
//
|
||||
// -- 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 ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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, "U")) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
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, "L")) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
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;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
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_
|
||||
|
||||
Vendored
+367
@@ -0,0 +1,367 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DCOMBSSQ adds two scaled sum of squares quantities.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DCOMBSSQ( V1, V2 )
|
||||
//
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION V1( 2 ), V2( 2 )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DCOMBSSQ adds two scaled sum of squares quantities, V1 := V1 + V2.
|
||||
//> That is,
|
||||
//>
|
||||
//> V1_scale**2 * V1_sumsq := V1_scale**2 * V1_sumsq
|
||||
//> + V2_scale**2 * V2_sumsq
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in,out] V1
|
||||
//> \verbatim
|
||||
//> V1 is DOUBLE PRECISION array, dimension (2).
|
||||
//> The first scaled sum.
|
||||
//> V1(1) = V1_scale, V1(2) = V1_sumsq.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] V2
|
||||
//> \verbatim
|
||||
//> V2 is DOUBLE PRECISION array, dimension (2).
|
||||
//> The second scaled sum.
|
||||
//> V2(1) = V2_scale, V2(2) = V2_sumsq.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2018
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dcombssq_(double *v1, double *v2)
|
||||
{
|
||||
// System generated locals
|
||||
double d__1;
|
||||
|
||||
//
|
||||
// -- 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..--
|
||||
// November 2018
|
||||
//
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
//=====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
--v2;
|
||||
--v1;
|
||||
|
||||
// Function Body
|
||||
if (v1[1] >= v2[1]) {
|
||||
if (v1[1] != 0.) {
|
||||
// Computing 2nd power
|
||||
d__1 = v2[1] / v1[1];
|
||||
v1[2] += d__1 * d__1 * v2[2];
|
||||
}
|
||||
} else {
|
||||
// Computing 2nd power
|
||||
d__1 = v1[1] / v2[1];
|
||||
v1[2] = v2[2] + d__1 * d__1 * v1[2];
|
||||
v1[1] = v2[1];
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DCOMBSSQ
|
||||
//
|
||||
} // dcombssq_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleGEauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
double dlange_(char *norm, int *m, int *n, double *a, int *lda, double *work)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
double ret_val, d__1;
|
||||
|
||||
// Local variables
|
||||
extern /* Subroutine */ int dcombssq_(double *, double *);
|
||||
int i__, j;
|
||||
double sum, ssq[2], temp;
|
||||
extern int lsame_(char *, char *);
|
||||
double value;
|
||||
extern int disnan_(double *);
|
||||
extern /* Subroutine */ int dlassq_(int *, double *, int *, double *,
|
||||
double *);
|
||||
double colssq[2];
|
||||
|
||||
//
|
||||
// -- 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 ..
|
||||
// ..
|
||||
// .. Local Arrays ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
if (min(*m,*n) == 0) {
|
||||
value = 0.;
|
||||
} else if (lsame_(norm, "M")) {
|
||||
//
|
||||
// Find max(abs(A(i,j))).
|
||||
//
|
||||
value = 0.;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
|
||||
if (value < temp || disnan_(&temp)) {
|
||||
value = temp;
|
||||
}
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
|
||||
//
|
||||
// Find norm1(A).
|
||||
//
|
||||
value = 0.;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
sum = 0.;
|
||||
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, "I")) {
|
||||
//
|
||||
// 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;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
temp = work[i__];
|
||||
if (value < temp || disnan_(&temp)) {
|
||||
value = temp;
|
||||
}
|
||||
// L80:
|
||||
}
|
||||
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
|
||||
//
|
||||
// Find normF(A).
|
||||
// SSQ(1) is scale
|
||||
// SSQ(2) is sum-of-squares
|
||||
// For better accuracy, sum each column separately.
|
||||
//
|
||||
ssq[0] = 0.;
|
||||
ssq[1] = 1.;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
colssq[0] = 0.;
|
||||
colssq[1] = 1.;
|
||||
dlassq_(m, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]);
|
||||
dcombssq_(ssq, colssq);
|
||||
// L90:
|
||||
}
|
||||
value = ssq[0] * sqrt(ssq[1]);
|
||||
}
|
||||
ret_val = value;
|
||||
return ret_val;
|
||||
//
|
||||
// End of DLANGE
|
||||
//
|
||||
} // dlange_
|
||||
|
||||
Vendored
+125
@@ -0,0 +1,125 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//> \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.
|
||||
//
|
||||
//> \date June 2017
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
double dlapy2_(double *x, double *y)
|
||||
{
|
||||
// System generated locals
|
||||
double ret_val, d__1;
|
||||
|
||||
// Local variables
|
||||
int x_is_nan__, y_is_nan__;
|
||||
double w, z__, xabs, yabs;
|
||||
extern int disnan_(double *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.1) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
x_is_nan__ = disnan_(x);
|
||||
y_is_nan__ = disnan_(y);
|
||||
if (x_is_nan__) {
|
||||
ret_val = *x;
|
||||
}
|
||||
if (y_is_nan__) {
|
||||
ret_val = *y;
|
||||
}
|
||||
if (! (x_is_nan__ || y_is_nan__)) {
|
||||
xabs = abs(*x);
|
||||
yabs = abs(*y);
|
||||
w = max(xabs,yabs);
|
||||
z__ = min(xabs,yabs);
|
||||
if (z__ == 0.) {
|
||||
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_
|
||||
|
||||
Vendored
+768
@@ -0,0 +1,768 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \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_(int *m, int *n, double *alpha, double *x, int *
|
||||
incx, double *y, int *incy, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j, ix, jy, kx, info;
|
||||
double temp;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level2 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 ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
// Parameter adjustments
|
||||
--x;
|
||||
--y;
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
|
||||
// Function Body
|
||||
info = 0;
|
||||
if (*m < 0) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*incx == 0) {
|
||||
info = 5;
|
||||
} else if (*incy == 0) {
|
||||
info = 7;
|
||||
} else if (*lda < max(1,*m)) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DGER ", &info);
|
||||
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 {
|
||||
jy = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
if (*incx == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (y[jy] != 0.) {
|
||||
temp = *alpha * y[jy];
|
||||
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) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*m - 1) * *incx;
|
||||
}
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (y[jy] != 0.) {
|
||||
temp = *alpha * y[jy];
|
||||
ix = kx;
|
||||
i__2 = *m;
|
||||
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_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlarf_(char *side, int *m, int *n, double *v, int *incv,
|
||||
double *tau, double *c__, int *ldc, double *work)
|
||||
{
|
||||
// Table of constant values
|
||||
double c_b4 = 1.;
|
||||
double c_b5 = 0.;
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int c_dim1, c_offset;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int i__;
|
||||
int applyleft;
|
||||
extern /* Subroutine */ int dger_(int *, int *, double *, double *, int *,
|
||||
double *, int *, double *, int *);
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int dgemv_(char *, int *, int *, double *, double
|
||||
*, int *, double *, int *, double *, double *, int *);
|
||||
int lastc, lastv;
|
||||
extern int iladlc_(int *, int *, double *, int *), iladlr_(int *, int *,
|
||||
double *, int *);
|
||||
|
||||
//
|
||||
// -- 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 Subroutines ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
--v;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
applyleft = lsame_(side, "L");
|
||||
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 {
|
||||
lastv = *n;
|
||||
}
|
||||
if (*incv > 0) {
|
||||
i__ = (lastv - 1) * *incv + 1;
|
||||
} else {
|
||||
i__ = 1;
|
||||
}
|
||||
// Look for the last non-zero row in V.
|
||||
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_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
|
||||
v[1], incv, &c_b5, &work[1], &c__1);
|
||||
//
|
||||
// C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
|
||||
//
|
||||
d__1 = -(*tau);
|
||||
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_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc,
|
||||
&v[1], incv, &c_b5, &work[1], &c__1);
|
||||
//
|
||||
// C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
|
||||
//
|
||||
d__1 = -(*tau);
|
||||
dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
|
||||
c_offset], ldc);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARF
|
||||
//
|
||||
} // dlarf_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b ILADLC scans a matrix for its last non-zero column.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download ILADLC + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iladlc.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iladlc.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iladlc.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// INTEGER FUNCTION ILADLC( M, N, A, LDA )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER M, N, LDA
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> ILADLC scans A for its last non-zero column.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A.
|
||||
//> \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(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int iladlc_(int *m, int *n, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, ret_val, i__1;
|
||||
|
||||
// Local variables
|
||||
int i__;
|
||||
|
||||
//
|
||||
// -- 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 ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick test for the common case where one corner is non-zero.
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
|
||||
// Function Body
|
||||
if (*n == 0) {
|
||||
ret_val = *n;
|
||||
} else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) {
|
||||
ret_val = *n;
|
||||
} else {
|
||||
// Now scan each column from the end, returning with the first non-zero.
|
||||
for (ret_val = *n; ret_val >= 1; --ret_val) {
|
||||
i__1 = *m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
if (a[i__ + ret_val * a_dim1] != 0.) {
|
||||
return ret_val;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return ret_val;
|
||||
} // iladlc_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b ILADLR scans a matrix for its last non-zero row.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download ILADLR + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iladlr.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iladlr.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iladlr.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// INTEGER FUNCTION ILADLR( M, N, A, LDA )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER M, N, LDA
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> ILADLR scans A for its last non-zero row.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A.
|
||||
//> \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(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int iladlr_(int *m, int *n, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, ret_val, i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
|
||||
//
|
||||
// -- 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 ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick test for the common case where one corner is non-zero.
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
|
||||
// Function Body
|
||||
if (*m == 0) {
|
||||
ret_val = *m;
|
||||
} else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) {
|
||||
ret_val = *m;
|
||||
} else {
|
||||
// Scan up each column tracking the last zero row seen.
|
||||
ret_val = 0;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__ = *m;
|
||||
while(a[max(i__,1) + j * a_dim1] == 0. && i__ >= 1) {
|
||||
--i__;
|
||||
}
|
||||
ret_val = max(ret_val,i__);
|
||||
}
|
||||
}
|
||||
return ret_val;
|
||||
} // iladlr_
|
||||
|
||||
Vendored
+824
@@ -0,0 +1,824 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLARFB + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
// T, LDT, C, LDC, WORK, LDWORK )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
// INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
// $ WORK( LDWORK, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLARFB applies a real block reflector H or its transpose H**T to a
|
||||
//> real m by n matrix C, from either the left or the right.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] SIDE
|
||||
//> \verbatim
|
||||
//> SIDE is CHARACTER*1
|
||||
//> = 'L': apply H or H**T from the Left
|
||||
//> = 'R': apply H or H**T from the Right
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANS
|
||||
//> \verbatim
|
||||
//> TRANS is CHARACTER*1
|
||||
//> = 'N': apply H (No transpose)
|
||||
//> = 'T': apply H**T (Transpose)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DIRECT
|
||||
//> \verbatim
|
||||
//> DIRECT is CHARACTER*1
|
||||
//> Indicates how H is formed from a product of elementary
|
||||
//> reflectors
|
||||
//> = '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
|
||||
//> Indicates how the vectors which define the elementary
|
||||
//> reflectors are stored:
|
||||
//> = 'C': Columnwise
|
||||
//> = 'R': Rowwise
|
||||
//> \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] K
|
||||
//> \verbatim
|
||||
//> K is INTEGER
|
||||
//> The order of the matrix T (= the number of elementary
|
||||
//> reflectors whose product defines the block reflector).
|
||||
//> If SIDE = 'L', M >= K >= 0;
|
||||
//> if SIDE = 'R', N >= K >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] V
|
||||
//> \verbatim
|
||||
//> V is DOUBLE PRECISION array, dimension
|
||||
//> (LDV,K) if STOREV = 'C'
|
||||
//> (LDV,M) if STOREV = 'R' and SIDE = 'L'
|
||||
//> (LDV,N) if STOREV = 'R' and SIDE = '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' and SIDE = 'L', LDV >= max(1,M);
|
||||
//> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
|
||||
//> if STOREV = 'R', LDV >= K.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] T
|
||||
//> \verbatim
|
||||
//> T is DOUBLE PRECISION array, dimension (LDT,K)
|
||||
//> The triangular k by k matrix T in the representation of the
|
||||
//> block reflector.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDT
|
||||
//> \verbatim
|
||||
//> LDT is INTEGER
|
||||
//> The leading dimension of the array T. LDT >= K.
|
||||
//> \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 H*C or H**T*C or C*H or C*H**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 (LDWORK,K)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDWORK
|
||||
//> \verbatim
|
||||
//> LDWORK is INTEGER
|
||||
//> The leading dimension of the array WORK.
|
||||
//> If SIDE = 'L', LDWORK >= max(1,N);
|
||||
//> if SIDE = 'R', LDWORK >= max(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2013
|
||||
//
|
||||
//> \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; the corresponding
|
||||
//> array elements are modified but restored on exit. The rest of the
|
||||
//> array is not used.
|
||||
//>
|
||||
//> 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 dlarfb_(char *side, char *trans, char *direct, char *
|
||||
storev, int *m, int *n, int *k, double *v, int *ldv, double *t, int *
|
||||
ldt, double *c__, int *ldc, double *work, int *ldwork)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
double c_b14 = 1.;
|
||||
double c_b25 = -1.;
|
||||
|
||||
// System generated locals
|
||||
int c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
|
||||
work_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *,
|
||||
double *, double *, int *, double *, int *, double *, double *,
|
||||
int *);
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int *
|
||||
), dtrmm_(char *, char *, char *, char *, int *, int *, double *,
|
||||
double *, int *, double *, int *);
|
||||
char transt[1+1]={'\0'};
|
||||
|
||||
//
|
||||
// -- 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..--
|
||||
// June 2013
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
// Parameter adjustments
|
||||
v_dim1 = *ldv;
|
||||
v_offset = 1 + v_dim1;
|
||||
v -= v_offset;
|
||||
t_dim1 = *ldt;
|
||||
t_offset = 1 + t_dim1;
|
||||
t -= t_offset;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
work_dim1 = *ldwork;
|
||||
work_offset = 1 + work_dim1;
|
||||
work -= work_offset;
|
||||
|
||||
// Function Body
|
||||
if (*m <= 0 || *n <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(trans, "N")) {
|
||||
*(unsigned char *)transt = 'T';
|
||||
} else {
|
||||
*(unsigned char *)transt = 'N';
|
||||
}
|
||||
if (lsame_(storev, "C")) {
|
||||
if (lsame_(direct, "F")) {
|
||||
//
|
||||
// Let V = ( V1 ) (first K rows)
|
||||
// ( V2 )
|
||||
// where V1 is unit lower triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
//
|
||||
// W := C1**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
|
||||
&c__1);
|
||||
// L10:
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C2**T * V2
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
|
||||
c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1],
|
||||
ldv, &c_b14, &work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C2 := C2 - V2 * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
|
||||
v[*k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L20:
|
||||
}
|
||||
// L30:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H**T where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
//
|
||||
// W := C1
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L40:
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C2 * V2
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, k, &i__1, &
|
||||
c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k +
|
||||
1 + v_dim1], ldv, &c_b14, &work[work_offset],
|
||||
ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V**T
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C2 := C2 - W * V2**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
|
||||
work[work_offset], ldwork, &v[*k + 1 + v_dim1],
|
||||
ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L50:
|
||||
}
|
||||
// L60:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Let V = ( V1 )
|
||||
// ( V2 ) (last K rows)
|
||||
// where V2 is unit upper triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
//
|
||||
// W := C2**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L70:
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C1**T * V1
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
|
||||
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
|
||||
work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C1 := C1 - V1 * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork, &
|
||||
c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
//
|
||||
// C2 := C2 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L80:
|
||||
}
|
||||
// L90:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H**T where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
//
|
||||
// W := C2
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
|
||||
j * work_dim1 + 1], &c__1);
|
||||
// L100:
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C1 * V1
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, k, &i__1, &
|
||||
c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
|
||||
c_b14, &work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V**T
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C1 := C1 - W * V1**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
|
||||
work[work_offset], ldwork, &v[v_offset], ldv, &
|
||||
c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
//
|
||||
// C2 := C2 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L110:
|
||||
}
|
||||
// L120:
|
||||
}
|
||||
}
|
||||
}
|
||||
} else if (lsame_(storev, "R")) {
|
||||
if (lsame_(direct, "F")) {
|
||||
//
|
||||
// Let V = ( V1 V2 ) (V1: first K columns)
|
||||
// where V1 is unit upper triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C1**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
|
||||
&c__1);
|
||||
// L130:
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C2**T * V2**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
|
||||
c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 +
|
||||
1], ldv, &c_b14, &work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V**T * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C2 := C2 - V2**T * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[(
|
||||
*k + 1) * v_dim1 + 1], ldv, &work[work_offset],
|
||||
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L140:
|
||||
}
|
||||
// L150:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H**T where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C1
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L160:
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C2 * V2**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
|
||||
c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) *
|
||||
v_dim1 + 1], ldv, &c_b14, &work[work_offset],
|
||||
ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C2 := C2 - W * V2
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, &i__1, k, &
|
||||
c_b25, &work[work_offset], ldwork, &v[(*k + 1) *
|
||||
v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1
|
||||
+ 1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L170:
|
||||
}
|
||||
// L180:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Let V = ( V1 V2 ) (V2: last K columns)
|
||||
// where V2 is unit lower triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C2**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L190:
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
|
||||
, ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C1**T * V1**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
|
||||
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
|
||||
work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V**T * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C1 := C1 - V1**T * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[
|
||||
v_offset], ldv, &work[work_offset], ldwork, &
|
||||
c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[
|
||||
work_offset], ldwork);
|
||||
//
|
||||
// C2 := C2 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L200:
|
||||
}
|
||||
// L210:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H' where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C2
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
|
||||
j * work_dim1 + 1], &c__1);
|
||||
// L220:
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
|
||||
, ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C1 * V1**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
|
||||
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
|
||||
work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C1 := C1 - W * V1
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, &i__1, k, &
|
||||
c_b25, &work[work_offset], ldwork, &v[v_offset],
|
||||
ldv, &c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[
|
||||
work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L230:
|
||||
}
|
||||
// L240:
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARFB
|
||||
//
|
||||
} // dlarfb_
|
||||
|
||||
Vendored
+216
@@ -0,0 +1,216 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup doubleOTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlarfg_(int *n, double *alpha, double *x, int *incx,
|
||||
double *tau)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int j, knt;
|
||||
double beta;
|
||||
extern double dnrm2_(int *, double *, int *);
|
||||
extern /* Subroutine */ int dscal_(int *, double *, double *, int *);
|
||||
double xnorm;
|
||||
extern double dlapy2_(double *, double *), dlamch_(char *);
|
||||
double safmin, rsafmn;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.8.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. 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_sign(&d__1, alpha);
|
||||
safmin = dlamch_("S") / dlamch_("E");
|
||||
knt = 0;
|
||||
if (abs(beta) < safmin) {
|
||||
//
|
||||
// XNORM, BETA may be inaccurate; scale X and recompute them
|
||||
//
|
||||
rsafmn = 1. / safmin;
|
||||
L10:
|
||||
++knt;
|
||||
i__1 = *n - 1;
|
||||
dscal_(&i__1, &rsafmn, &x[1], incx);
|
||||
beta *= rsafmn;
|
||||
*alpha *= rsafmn;
|
||||
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);
|
||||
beta = -d_sign(&d__1, alpha);
|
||||
}
|
||||
*tau = (beta - *alpha) / beta;
|
||||
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_
|
||||
|
||||
Vendored
+389
@@ -0,0 +1,389 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \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, int *n, int *k,
|
||||
double *v, int *ldv, double *tau, double *t, int *ldt)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
double c_b7 = 1.;
|
||||
|
||||
// System generated locals
|
||||
int t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int i__, j, prevlastv;
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int dgemv_(char *, int *, int *, double *, double
|
||||
*, int *, double *, int *, double *, double *, int *);
|
||||
int lastv;
|
||||
extern /* Subroutine */ int dtrmv_(char *, char *, char *, int *, double *
|
||||
, int *, double *, int *);
|
||||
|
||||
//
|
||||
// -- 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 Subroutines ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
// Parameter adjustments
|
||||
v_dim1 = *ldv;
|
||||
v_offset = 1 + v_dim1;
|
||||
v -= v_offset;
|
||||
--tau;
|
||||
t_dim1 = *ldt;
|
||||
t_offset = 1 + t_dim1;
|
||||
t -= t_offset;
|
||||
|
||||
// Function Body
|
||||
if (*n == 0) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(direct, "F")) {
|
||||
prevlastv = *n;
|
||||
i__1 = *k;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
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, "C")) {
|
||||
// Skip any trailing zeros.
|
||||
i__2 = i__ + 1;
|
||||
for (lastv = *n; lastv >= i__2; --lastv) {
|
||||
if (v[lastv + i__ * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
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)
|
||||
//
|
||||
i__2 = j - i__;
|
||||
i__3 = i__ - 1;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("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);
|
||||
} else {
|
||||
// Skip any trailing zeros.
|
||||
i__2 = i__ + 1;
|
||||
for (lastv = *n; lastv >= i__2; --lastv) {
|
||||
if (v[i__ + lastv * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
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
|
||||
//
|
||||
i__2 = i__ - 1;
|
||||
i__3 = j - i__;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("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);
|
||||
}
|
||||
//
|
||||
// T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
|
||||
//
|
||||
i__2 = i__ - 1;
|
||||
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
|
||||
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
|
||||
t[i__ + i__ * t_dim1] = tau[i__];
|
||||
if (i__ > 1) {
|
||||
prevlastv = max(prevlastv,lastv);
|
||||
} else {
|
||||
prevlastv = lastv;
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
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, "C")) {
|
||||
// Skip any leading zeros.
|
||||
i__1 = i__ - 1;
|
||||
for (lastv = 1; lastv <= i__1; ++lastv) {
|
||||
if (v[lastv + i__ * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
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];
|
||||
}
|
||||
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)
|
||||
//
|
||||
i__1 = *n - *k + i__ - j;
|
||||
i__2 = *k - i__;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("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);
|
||||
} else {
|
||||
// Skip any leading zeros.
|
||||
i__1 = i__ - 1;
|
||||
for (lastv = 1; lastv <= i__1; ++lastv) {
|
||||
if (v[i__ + lastv * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
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];
|
||||
}
|
||||
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
|
||||
//
|
||||
i__1 = *k - i__;
|
||||
i__2 = *n - *k + i__ - j;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("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)
|
||||
;
|
||||
}
|
||||
//
|
||||
// T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
|
||||
//
|
||||
i__1 = *k - i__;
|
||||
dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
|
||||
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
|
||||
t_dim1], &c__1);
|
||||
if (i__ > 1) {
|
||||
prevlastv = min(prevlastv,lastv);
|
||||
} else {
|
||||
prevlastv = lastv;
|
||||
}
|
||||
}
|
||||
t[i__ + i__ * t_dim1] = tau[i__];
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARFT
|
||||
//
|
||||
} // dlarft_
|
||||
|
||||
Vendored
+236
@@ -0,0 +1,236 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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_(double *f, double *g, double *cs, double *sn,
|
||||
double *r__)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
double d__1, d__2;
|
||||
|
||||
// Local variables
|
||||
int i__;
|
||||
double f1, g1, eps, scale;
|
||||
int count;
|
||||
double safmn2, safmx2;
|
||||
extern double dlamch_(char *);
|
||||
double 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_("S");
|
||||
eps = dlamch_("E");
|
||||
d__1 = dlamch_("B");
|
||||
i__1 = (int) (log(safmin / eps) / log(dlamch_("B")) / 2.);
|
||||
safmn2 = pow_di(&d__1, &i__1);
|
||||
safmx2 = 1. / safmn2;
|
||||
// FIRST = .FALSE.
|
||||
// END IF
|
||||
if (*g == 0.) {
|
||||
*cs = 1.;
|
||||
*sn = 0.;
|
||||
*r__ = *f;
|
||||
} else if (*f == 0.) {
|
||||
*cs = 0.;
|
||||
*sn = 1.;
|
||||
*r__ = *g;
|
||||
} else {
|
||||
f1 = *f;
|
||||
g1 = *g;
|
||||
// Computing MAX
|
||||
d__1 = abs(f1), d__2 = abs(g1);
|
||||
scale = max(d__1,d__2);
|
||||
if (scale >= safmx2) {
|
||||
count = 0;
|
||||
L10:
|
||||
++count;
|
||||
f1 *= safmn2;
|
||||
g1 *= safmn2;
|
||||
// Computing MAX
|
||||
d__1 = abs(f1), d__2 = abs(g1);
|
||||
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__;
|
||||
*sn = g1 / *r__;
|
||||
i__1 = count;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
*r__ *= safmx2;
|
||||
// L20:
|
||||
}
|
||||
} else if (scale <= safmn2) {
|
||||
count = 0;
|
||||
L30:
|
||||
++count;
|
||||
f1 *= safmx2;
|
||||
g1 *= safmx2;
|
||||
// Computing MAX
|
||||
d__1 = abs(f1), d__2 = abs(g1);
|
||||
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__;
|
||||
*sn = g1 / *r__;
|
||||
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__;
|
||||
*sn = g1 / *r__;
|
||||
}
|
||||
if (abs(*f) > abs(*g) && *cs < 0.) {
|
||||
*cs = -(*cs);
|
||||
*sn = -(*sn);
|
||||
*r__ = -(*r__);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARTG
|
||||
//
|
||||
} // dlartg_
|
||||
|
||||
Vendored
+413
@@ -0,0 +1,413 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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.
|
||||
//
|
||||
//> \date June 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlascl_(char *type__, int *kl, int *ku, double *cfrom,
|
||||
double *cto, int *m, int *n, double *a, int *lda, int *info)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
|
||||
|
||||
// Local variables
|
||||
int i__, j, k1, k2, k3, k4;
|
||||
double mul, cto1;
|
||||
int done;
|
||||
double ctoc;
|
||||
extern int lsame_(char *, char *);
|
||||
int itype;
|
||||
double cfrom1;
|
||||
extern double dlamch_(char *);
|
||||
double cfromc;
|
||||
extern int disnan_(double *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
double bignum, smlnum;
|
||||
|
||||
//
|
||||
// -- 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..--
|
||||
// June 2016
|
||||
//
|
||||
// .. 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__, "G")) {
|
||||
itype = 0;
|
||||
} else if (lsame_(type__, "L")) {
|
||||
itype = 1;
|
||||
} else if (lsame_(type__, "U")) {
|
||||
itype = 2;
|
||||
} else if (lsame_(type__, "H")) {
|
||||
itype = 3;
|
||||
} else if (lsame_(type__, "B")) {
|
||||
itype = 4;
|
||||
} else if (lsame_(type__, "Q")) {
|
||||
itype = 5;
|
||||
} else if (lsame_(type__, "Z")) {
|
||||
itype = 6;
|
||||
} else {
|
||||
itype = -1;
|
||||
}
|
||||
if (itype == -1) {
|
||||
*info = -1;
|
||||
} else if (*cfrom == 0. || disnan_(cfrom)) {
|
||||
*info = -4;
|
||||
} else if (disnan_(cto)) {
|
||||
*info = -5;
|
||||
} else if (*m < 0) {
|
||||
*info = -6;
|
||||
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
|
||||
*info = -7;
|
||||
} 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)) {
|
||||
*info = -2;
|
||||
} else /* if(complicated condition) */ {
|
||||
// Computing MAX
|
||||
i__1 = *n - 1;
|
||||
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) {
|
||||
*info = -9;
|
||||
}
|
||||
}
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DLASCL", &i__1);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
if (*n == 0 || *m == 0) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Get machine parameters
|
||||
//
|
||||
smlnum = dlamch_("S");
|
||||
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.;
|
||||
} else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
|
||||
mul = smlnum;
|
||||
done = FALSE_;
|
||||
cfromc = cfrom1;
|
||||
} else if (abs(cto1) > abs(cfromc)) {
|
||||
mul = bignum;
|
||||
done = FALSE_;
|
||||
ctoc = cto1;
|
||||
} else {
|
||||
mul = ctoc / cfromc;
|
||||
done = TRUE_;
|
||||
}
|
||||
}
|
||||
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);
|
||||
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);
|
||||
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);
|
||||
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__) {
|
||||
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__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L140:
|
||||
}
|
||||
// L150:
|
||||
}
|
||||
}
|
||||
if (! done) {
|
||||
goto L10;
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLASCL
|
||||
//
|
||||
} // dlascl_
|
||||
|
||||
Vendored
+209
@@ -0,0 +1,209 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
|
||||
//
|
||||
// =========== 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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlaset_(char *uplo, int *m, int *n, double *alpha,
|
||||
double *beta, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2, i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
extern int lsame_(char *, char *);
|
||||
|
||||
//
|
||||
// -- 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 ..
|
||||
// ..
|
||||
//
|
||||
//=====================================================================
|
||||
//
|
||||
// .. 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, "U")) {
|
||||
//
|
||||
// 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);
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] = *alpha;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else if (lsame_(uplo, "L")) {
|
||||
//
|
||||
// Set the strictly lower triangular or trapezoidal part of the
|
||||
// array to ALPHA.
|
||||
//
|
||||
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);
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
a[i__ + i__ * a_dim1] = *beta;
|
||||
// L70:
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLASET
|
||||
//
|
||||
} // dlaset_
|
||||
|
||||
Vendored
+172
@@ -0,0 +1,172 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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 (1+(N-1)*INCX)
|
||||
//> 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_(int *n, double *x, int *incx, double *scale,
|
||||
double *sumsq)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1, i__2;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int ix;
|
||||
double absxi;
|
||||
extern int disnan_(double *);
|
||||
|
||||
//
|
||||
// -- 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;
|
||||
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
|
||||
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_
|
||||
|
||||
Vendored
+149
@@ -0,0 +1,149 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "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 November 2017
|
||||
//
|
||||
//> \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
|
||||
//>
|
||||
// =====================================================================
|
||||
double dnrm2_(int *n, double *x, int *incx)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1, i__2;
|
||||
double ret_val, d__1;
|
||||
|
||||
// Local variables
|
||||
int ix;
|
||||
double ssq, norm, scale, absxi;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. 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) {
|
||||
norm = abs(x[1]);
|
||||
} 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_
|
||||
|
||||
Vendored
+571
@@ -0,0 +1,571 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dorg2r_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l;
|
||||
extern /* Subroutine */ int dscal_(int *, double *, double *, int *),
|
||||
dlarf_(char *, int *, int *, double *, int *, double *, double *,
|
||||
int *, double *), xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- LAPACK computational 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 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;
|
||||
if (*m < 0) {
|
||||
*info = -1;
|
||||
} else if (*n < 0 || *n > *m) {
|
||||
*info = -2;
|
||||
} else if (*k < 0 || *k > *n) {
|
||||
*info = -3;
|
||||
} else if (*lda < max(1,*m)) {
|
||||
*info = -5;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORG2R", &i__1);
|
||||
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_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
|
||||
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
|
||||
}
|
||||
if (i__ < *m) {
|
||||
i__1 = *m - i__;
|
||||
d__1 = -tau[i__];
|
||||
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_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dorgqr_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *lwork, int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
int c_n1 = -1;
|
||||
int c__3 = 3;
|
||||
int c__2 = 2;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2, i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
|
||||
extern /* Subroutine */ int dorg2r_(int *, int *, int *, double *, int *,
|
||||
double *, double *, int *), dlarfb_(char *, char *, char *, char *
|
||||
, int *, int *, int *, double *, int *, double *, int *, double *,
|
||||
int *, double *, int *), dlarft_(char *, char *, int *, int *,
|
||||
double *, int *, double *, double *, int *), xerbla_(char *, int *
|
||||
);
|
||||
extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *);
|
||||
int ldwork, lwkopt;
|
||||
int lquery;
|
||||
|
||||
//
|
||||
// -- LAPACK computational 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 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, "DORGQR", " ", m, n, k, &c_n1);
|
||||
lwkopt = max(1,*n) * nb;
|
||||
work[1] = (double) lwkopt;
|
||||
lquery = *lwork == -1;
|
||||
if (*m < 0) {
|
||||
*info = -1;
|
||||
} else if (*n < 0 || *n > *m) {
|
||||
*info = -2;
|
||||
} else if (*k < 0 || *k > *n) {
|
||||
*info = -3;
|
||||
} else if (*lda < max(1,*m)) {
|
||||
*info = -5;
|
||||
} else if (*lwork < max(1,*n) && ! lquery) {
|
||||
*info = -8;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORGQR", &i__1);
|
||||
return 0;
|
||||
} 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, "DORGQR", " ", m, n, k, &c_n1);
|
||||
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, "DORGQR", " ", m, n, k, &c_n1)
|
||||
;
|
||||
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.
|
||||
//
|
||||
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);
|
||||
}
|
||||
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);
|
||||
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_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
|
||||
a_dim1], lda, &tau[i__], &work[1], &ldwork);
|
||||
//
|
||||
// Apply H to A(i:m,i+ib:n) from the left
|
||||
//
|
||||
i__2 = *m - i__ + 1;
|
||||
i__3 = *n - i__ - ib + 1;
|
||||
dlarfb_("Left", "No transpose", "Forward", "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);
|
||||
}
|
||||
//
|
||||
// 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
|
||||
//
|
||||
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] = (double) iws;
|
||||
return 0;
|
||||
//
|
||||
// End of DORGQR
|
||||
//
|
||||
} // dorgqr_
|
||||
|
||||
Vendored
+684
@@ -0,0 +1,684 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dorm2r_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, i1, i2, i3, ic, jc, mi, ni, nq;
|
||||
double aii;
|
||||
int left;
|
||||
extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *,
|
||||
double *, double *, int *, double *);
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
int notran;
|
||||
|
||||
//
|
||||
// -- LAPACK computational 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 ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Test the input arguments
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--tau;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
*info = 0;
|
||||
left = lsame_(side, "L");
|
||||
notran = lsame_(trans, "N");
|
||||
//
|
||||
// NQ is the order of Q
|
||||
//
|
||||
if (left) {
|
||||
nq = *m;
|
||||
} else {
|
||||
nq = *n;
|
||||
}
|
||||
if (! left && ! lsame_(side, "R")) {
|
||||
*info = -1;
|
||||
} else if (! notran && ! lsame_(trans, "T")) {
|
||||
*info = -2;
|
||||
} else if (*m < 0) {
|
||||
*info = -3;
|
||||
} else if (*n < 0) {
|
||||
*info = -4;
|
||||
} else if (*k < 0 || *k > nq) {
|
||||
*info = -5;
|
||||
} else if (*lda < max(1,nq)) {
|
||||
*info = -7;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
*info = -10;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORM2R", &i__1);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
if (*m == 0 || *n == 0 || *k == 0) {
|
||||
return 0;
|
||||
}
|
||||
if (left && ! notran || ! left && notran) {
|
||||
i1 = 1;
|
||||
i2 = *k;
|
||||
i3 = 1;
|
||||
} else {
|
||||
i1 = *k;
|
||||
i2 = 1;
|
||||
i3 = -1;
|
||||
}
|
||||
if (left) {
|
||||
ni = *n;
|
||||
jc = 1;
|
||||
} else {
|
||||
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]);
|
||||
a[i__ + i__ * a_dim1] = aii;
|
||||
// L10:
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DORM2R
|
||||
//
|
||||
} // dorm2r_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b DORMQR
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DORMQR + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dormqr.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dormqr.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dormqr.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DORMQR( 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
|
||||
//>
|
||||
//> DORMQR 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(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': 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
|
||||
//> DGEQRF in the first 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 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 (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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dormqr_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *lwork, int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
int c_n1 = -1;
|
||||
int c__2 = 2;
|
||||
int c__65 = 65;
|
||||
|
||||
// System generated locals
|
||||
address a__1[2];
|
||||
int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5;
|
||||
char ch__1[2+1]={'\0'};
|
||||
|
||||
// Local variables
|
||||
int i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt;
|
||||
int left;
|
||||
extern int lsame_(char *, char *);
|
||||
int nbmin, iinfo;
|
||||
extern /* Subroutine */ int dorm2r_(char *, char *, int *, int *, int *,
|
||||
double *, int *, double *, double *, int *, double *, int *),
|
||||
dlarfb_(char *, char *, char *, char *, int *, int *, int *,
|
||||
double *, int *, double *, int *, double *, int *, double *, int *
|
||||
), dlarft_(char *, char *, int *, int *, double *, int *, double *
|
||||
, double *, int *), xerbla_(char *, int *);
|
||||
extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *);
|
||||
int notran;
|
||||
int ldwork, lwkopt;
|
||||
int lquery;
|
||||
|
||||
//
|
||||
// -- LAPACK computational 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 ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Test the input arguments
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--tau;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
*info = 0;
|
||||
left = lsame_(side, "L");
|
||||
notran = lsame_(trans, "N");
|
||||
lquery = *lwork == -1;
|
||||
//
|
||||
// NQ is the order of Q and NW is the minimum dimension of WORK
|
||||
//
|
||||
if (left) {
|
||||
nq = *m;
|
||||
nw = *n;
|
||||
} else {
|
||||
nq = *n;
|
||||
nw = *m;
|
||||
}
|
||||
if (! left && ! lsame_(side, "R")) {
|
||||
*info = -1;
|
||||
} else if (! notran && ! lsame_(trans, "T")) {
|
||||
*info = -2;
|
||||
} else if (*m < 0) {
|
||||
*info = -3;
|
||||
} else if (*n < 0) {
|
||||
*info = -4;
|
||||
} else if (*k < 0 || *k > nq) {
|
||||
*info = -5;
|
||||
} else if (*lda < max(1,nq)) {
|
||||
*info = -7;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
*info = -10;
|
||||
} else if (*lwork < max(1,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_cat(ch__1, a__1, i__3, &c__2);
|
||||
i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1);
|
||||
nb = min(i__1,i__2);
|
||||
lwkopt = max(1,nw) * nb + 4160;
|
||||
work[1] = (double) lwkopt;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORMQR", &i__1);
|
||||
return 0;
|
||||
} 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 < nw * nb + 4160) {
|
||||
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_cat(ch__1, a__1, i__3, &c__2);
|
||||
i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1);
|
||||
nbmin = max(i__1,i__2);
|
||||
}
|
||||
}
|
||||
if (nb < nbmin || nb >= *k) {
|
||||
//
|
||||
// Use unblocked code
|
||||
//
|
||||
dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
|
||||
c_offset], ldc, &work[1], &iinfo);
|
||||
} else {
|
||||
//
|
||||
// Use blocked code
|
||||
//
|
||||
iwt = nw * nb + 1;
|
||||
if (left && ! notran || ! left && notran) {
|
||||
i1 = 1;
|
||||
i2 = *k;
|
||||
i3 = nb;
|
||||
} else {
|
||||
i1 = (*k - 1) / nb * nb + 1;
|
||||
i2 = 1;
|
||||
i3 = -nb;
|
||||
}
|
||||
if (left) {
|
||||
ni = *n;
|
||||
jc = 1;
|
||||
} else {
|
||||
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) {
|
||||
// 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)
|
||||
//
|
||||
i__4 = nq - i__ + 1;
|
||||
dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
|
||||
a_dim1], lda, &tau[i__], &work[iwt], &c__65);
|
||||
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, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
|
||||
i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic +
|
||||
jc * c_dim1], ldc, &work[1], &ldwork);
|
||||
// L10:
|
||||
}
|
||||
}
|
||||
work[1] = (double) lwkopt;
|
||||
return 0;
|
||||
//
|
||||
// End of DORMQR
|
||||
//
|
||||
} // dormqr_
|
||||
|
||||
Vendored
+164
@@ -0,0 +1,164 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DROT
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION C,S
|
||||
// INTEGER INCX,INCY,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*),DY(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DROT applies a plane rotation.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> number of elements in input vector(s)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] 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
|
||||
//>
|
||||
//> \param[in] C
|
||||
//> \verbatim
|
||||
//> C is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] S
|
||||
//> \verbatim
|
||||
//> S is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \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 drot_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy, double *c__, double *s)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, ix, iy;
|
||||
double dtemp;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// Parameter adjustments
|
||||
--dy;
|
||||
--dx;
|
||||
|
||||
// Function Body
|
||||
if (*n <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
//
|
||||
// code for both increments equal to 1
|
||||
//
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp = *c__ * dx[i__] + *s * dy[i__];
|
||||
dy[i__] = *c__ * dy[i__] - *s * dx[i__];
|
||||
dx[i__] = dtemp;
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// code for unequal increments or equal increments not equal
|
||||
// to 1
|
||||
//
|
||||
ix = 1;
|
||||
iy = 1;
|
||||
if (*incx < 0) {
|
||||
ix = (-(*n) + 1) * *incx + 1;
|
||||
}
|
||||
if (*incy < 0) {
|
||||
iy = (-(*n) + 1) * *incy + 1;
|
||||
}
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp = *c__ * dx[ix] + *s * dy[iy];
|
||||
dy[iy] = *c__ * dy[iy] - *s * dx[ix];
|
||||
dx[ix] = dtemp;
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // drot_
|
||||
|
||||
Vendored
+155
@@ -0,0 +1,155 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DSCAL
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DSCAL(N,DA,DX,INCX)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION DA
|
||||
// INTEGER INCX,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DSCAL scales a vector by a constant.
|
||||
//> uses unrolled loops for increment equal to 1.
|
||||
//> \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,out] 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.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \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
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dscal_(int *n, double *da, double *dx, int *incx)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, m, mp1, nincx;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// Parameter adjustments
|
||||
--dx;
|
||||
|
||||
// Function Body
|
||||
if (*n <= 0 || *incx <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (*incx == 1) {
|
||||
//
|
||||
// code for increment equal to 1
|
||||
//
|
||||
//
|
||||
// clean-up loop
|
||||
//
|
||||
m = *n % 5;
|
||||
if (m != 0) {
|
||||
i__1 = m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dx[i__] = *da * dx[i__];
|
||||
}
|
||||
if (*n < 5) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
mp1 = m + 1;
|
||||
i__1 = *n;
|
||||
for (i__ = mp1; i__ <= i__1; i__ += 5) {
|
||||
dx[i__] = *da * dx[i__];
|
||||
dx[i__ + 1] = *da * dx[i__ + 1];
|
||||
dx[i__ + 2] = *da * dx[i__ + 2];
|
||||
dx[i__ + 3] = *da * dx[i__ + 3];
|
||||
dx[i__ + 4] = *da * dx[i__ + 4];
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// code for increment not equal to 1
|
||||
//
|
||||
nincx = *n * *incx;
|
||||
i__1 = nincx;
|
||||
i__2 = *incx;
|
||||
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
|
||||
dx[i__] = *da * dx[i__];
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // dscal_
|
||||
|
||||
Vendored
+178
@@ -0,0 +1,178 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DSWAP
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX,INCY,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*),DY(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DSWAP interchanges two vectors.
|
||||
//> 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,out] 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.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \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 dswap_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, m, ix, iy, mp1;
|
||||
double dtemp;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. 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 % 3;
|
||||
if (m != 0) {
|
||||
i__1 = m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp = dx[i__];
|
||||
dx[i__] = dy[i__];
|
||||
dy[i__] = dtemp;
|
||||
}
|
||||
if (*n < 3) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
mp1 = m + 1;
|
||||
i__1 = *n;
|
||||
for (i__ = mp1; i__ <= i__1; i__ += 3) {
|
||||
dtemp = dx[i__];
|
||||
dx[i__] = dy[i__];
|
||||
dy[i__] = dtemp;
|
||||
dtemp = dx[i__ + 1];
|
||||
dx[i__ + 1] = dy[i__ + 1];
|
||||
dy[i__ + 1] = dtemp;
|
||||
dtemp = dx[i__ + 2];
|
||||
dx[i__ + 2] = dy[i__ + 2];
|
||||
dy[i__ + 2] = dtemp;
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// code for unequal increments or equal increments not equal
|
||||
// to 1
|
||||
//
|
||||
ix = 1;
|
||||
iy = 1;
|
||||
if (*incx < 0) {
|
||||
ix = (-(*n) + 1) * *incx + 1;
|
||||
}
|
||||
if (*incy < 0) {
|
||||
iy = (-(*n) + 1) * *incy + 1;
|
||||
}
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp = dx[ix];
|
||||
dx[ix] = dy[iy];
|
||||
dy[iy] = dtemp;
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // dswap_
|
||||
|
||||
Vendored
+509
@@ -0,0 +1,509 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DTRMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION ALPHA
|
||||
// INTEGER LDA,LDB,M,N
|
||||
// CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DTRMM performs one of the matrix-matrix operations
|
||||
//>
|
||||
//> B := alpha*op( A )*B, or B := alpha*B*op( A ),
|
||||
//>
|
||||
//> where alpha is a scalar, B is an m by n matrix, A is a unit, or
|
||||
//> non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
//>
|
||||
//> op( A ) = A or op( A ) = A**T.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] SIDE
|
||||
//> \verbatim
|
||||
//> SIDE is CHARACTER*1
|
||||
//> On entry, SIDE specifies whether op( A ) multiplies B from
|
||||
//> the left or right as follows:
|
||||
//>
|
||||
//> SIDE = 'L' or 'l' B := alpha*op( A )*B.
|
||||
//>
|
||||
//> SIDE = 'R' or 'r' B := alpha*B*op( A ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] UPLO
|
||||
//> \verbatim
|
||||
//> UPLO is CHARACTER*1
|
||||
//> On entry, UPLO specifies whether the matrix A is an upper or
|
||||
//> lower triangular matrix as follows:
|
||||
//>
|
||||
//> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
//>
|
||||
//> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \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] DIAG
|
||||
//> \verbatim
|
||||
//> DIAG is CHARACTER*1
|
||||
//> On entry, DIAG specifies whether or not A is unit triangular
|
||||
//> as follows:
|
||||
//>
|
||||
//> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
//>
|
||||
//> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
//> triangular.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> On entry, M specifies the number of rows of B. M must be at
|
||||
//> least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> On entry, N specifies the number of columns of B. N must be
|
||||
//> at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is DOUBLE PRECISION.
|
||||
//> On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
//> zero then A is not referenced and B need not be set before
|
||||
//> entry.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension ( LDA, k ), where k is m
|
||||
//> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
|
||||
//> Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
//> upper triangular part of the array A must contain the upper
|
||||
//> triangular matrix and the strictly lower triangular part of
|
||||
//> A is not referenced.
|
||||
//> Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
//> lower triangular part of the array A must contain the lower
|
||||
//> triangular matrix and the strictly upper triangular part of
|
||||
//> A is not referenced.
|
||||
//> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
//> A are not referenced either, but are assumed to be unity.
|
||||
//> \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 SIDE = 'L' or 'l' then
|
||||
//> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
//> then LDA must be at least max( 1, n ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] B
|
||||
//> \verbatim
|
||||
//> B is DOUBLE PRECISION array, dimension ( LDB, N )
|
||||
//> Before entry, the leading m by n part of the array B must
|
||||
//> contain the matrix B, and on exit is overwritten by the
|
||||
//> transformed matrix.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDB
|
||||
//> \verbatim
|
||||
//> LDB is INTEGER
|
||||
//> On entry, LDB specifies the first dimension of B as declared
|
||||
//> in the calling (sub) program. LDB 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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \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 dtrmm_(char *side, char *uplo, char *transa, char *diag,
|
||||
int *m, int *n, double *alpha, double *a, int *lda, double *b, int *
|
||||
ldb)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, k, info;
|
||||
double temp;
|
||||
int lside;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa;
|
||||
int upper;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
int nounit;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 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 ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
// 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
|
||||
lside = lsame_(side, "L");
|
||||
if (lside) {
|
||||
nrowa = *m;
|
||||
} else {
|
||||
nrowa = *n;
|
||||
}
|
||||
nounit = lsame_(diag, "N");
|
||||
upper = lsame_(uplo, "U");
|
||||
info = 0;
|
||||
if (! lside && ! lsame_(side, "R")) {
|
||||
info = 1;
|
||||
} else if (! upper && ! lsame_(uplo, "L")) {
|
||||
info = 2;
|
||||
} else if (! lsame_(transa, "N") && ! lsame_(transa, "T") && ! lsame_(
|
||||
transa, "C")) {
|
||||
info = 3;
|
||||
} else if (! lsame_(diag, "U") && ! lsame_(diag, "N")) {
|
||||
info = 4;
|
||||
} else if (*m < 0) {
|
||||
info = 5;
|
||||
} else if (*n < 0) {
|
||||
info = 6;
|
||||
} else if (*lda < max(1,nrowa)) {
|
||||
info = 9;
|
||||
} else if (*ldb < max(1,*m)) {
|
||||
info = 11;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DTRMM ", &info);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible.
|
||||
//
|
||||
if (*m == 0 || *n == 0) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// And when alpha.eq.zero.
|
||||
//
|
||||
if (*alpha == 0.) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
b[i__ + j * b_dim1] = 0.;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Start the operations.
|
||||
//
|
||||
if (lside) {
|
||||
if (lsame_(transa, "N")) {
|
||||
//
|
||||
// Form B := alpha*A*B.
|
||||
//
|
||||
if (upper) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (k = 1; k <= i__2; ++k) {
|
||||
if (b[k + j * b_dim1] != 0.) {
|
||||
temp = *alpha * b[k + j * b_dim1];
|
||||
i__3 = k - 1;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
b[i__ + j * b_dim1] += temp * a[i__ + k *
|
||||
a_dim1];
|
||||
// L30:
|
||||
}
|
||||
if (nounit) {
|
||||
temp *= a[k + k * a_dim1];
|
||||
}
|
||||
b[k + j * b_dim1] = temp;
|
||||
}
|
||||
// L40:
|
||||
}
|
||||
// L50:
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
for (k = *m; k >= 1; --k) {
|
||||
if (b[k + j * b_dim1] != 0.) {
|
||||
temp = *alpha * b[k + j * b_dim1];
|
||||
b[k + j * b_dim1] = temp;
|
||||
if (nounit) {
|
||||
b[k + j * b_dim1] *= a[k + k * a_dim1];
|
||||
}
|
||||
i__2 = *m;
|
||||
for (i__ = k + 1; i__ <= i__2; ++i__) {
|
||||
b[i__ + j * b_dim1] += temp * a[i__ + k *
|
||||
a_dim1];
|
||||
// L60:
|
||||
}
|
||||
}
|
||||
// L70:
|
||||
}
|
||||
// L80:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form B := alpha*A**T*B.
|
||||
//
|
||||
if (upper) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
for (i__ = *m; i__ >= 1; --i__) {
|
||||
temp = b[i__ + j * b_dim1];
|
||||
if (nounit) {
|
||||
temp *= a[i__ + i__ * a_dim1];
|
||||
}
|
||||
i__2 = i__ - 1;
|
||||
for (k = 1; k <= i__2; ++k) {
|
||||
temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
|
||||
// L90:
|
||||
}
|
||||
b[i__ + j * b_dim1] = *alpha * temp;
|
||||
// L100:
|
||||
}
|
||||
// L110:
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp = b[i__ + j * b_dim1];
|
||||
if (nounit) {
|
||||
temp *= a[i__ + i__ * a_dim1];
|
||||
}
|
||||
i__3 = *m;
|
||||
for (k = i__ + 1; k <= i__3; ++k) {
|
||||
temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
|
||||
// L120:
|
||||
}
|
||||
b[i__ + j * b_dim1] = *alpha * temp;
|
||||
// L130:
|
||||
}
|
||||
// L140:
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (lsame_(transa, "N")) {
|
||||
//
|
||||
// Form B := alpha*B*A.
|
||||
//
|
||||
if (upper) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
temp = *alpha;
|
||||
if (nounit) {
|
||||
temp *= a[j + j * a_dim1];
|
||||
}
|
||||
i__1 = *m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
|
||||
// L150:
|
||||
}
|
||||
i__1 = j - 1;
|
||||
for (k = 1; k <= i__1; ++k) {
|
||||
if (a[k + j * a_dim1] != 0.) {
|
||||
temp = *alpha * a[k + j * a_dim1];
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
b[i__ + j * b_dim1] += temp * b[i__ + k *
|
||||
b_dim1];
|
||||
// L160:
|
||||
}
|
||||
}
|
||||
// L170:
|
||||
}
|
||||
// L180:
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp = *alpha;
|
||||
if (nounit) {
|
||||
temp *= a[j + j * a_dim1];
|
||||
}
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
|
||||
// L190:
|
||||
}
|
||||
i__2 = *n;
|
||||
for (k = j + 1; k <= i__2; ++k) {
|
||||
if (a[k + j * a_dim1] != 0.) {
|
||||
temp = *alpha * a[k + j * a_dim1];
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
b[i__ + j * b_dim1] += temp * b[i__ + k *
|
||||
b_dim1];
|
||||
// L200:
|
||||
}
|
||||
}
|
||||
// L210:
|
||||
}
|
||||
// L220:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form B := alpha*B*A**T.
|
||||
//
|
||||
if (upper) {
|
||||
i__1 = *n;
|
||||
for (k = 1; k <= i__1; ++k) {
|
||||
i__2 = k - 1;
|
||||
for (j = 1; j <= i__2; ++j) {
|
||||
if (a[j + k * a_dim1] != 0.) {
|
||||
temp = *alpha * a[j + k * a_dim1];
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
b[i__ + j * b_dim1] += temp * b[i__ + k *
|
||||
b_dim1];
|
||||
// L230:
|
||||
}
|
||||
}
|
||||
// L240:
|
||||
}
|
||||
temp = *alpha;
|
||||
if (nounit) {
|
||||
temp *= a[k + k * a_dim1];
|
||||
}
|
||||
if (temp != 1.) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
|
||||
// L250:
|
||||
}
|
||||
}
|
||||
// L260:
|
||||
}
|
||||
} else {
|
||||
for (k = *n; k >= 1; --k) {
|
||||
i__1 = *n;
|
||||
for (j = k + 1; j <= i__1; ++j) {
|
||||
if (a[j + k * a_dim1] != 0.) {
|
||||
temp = *alpha * a[j + k * a_dim1];
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
b[i__ + j * b_dim1] += temp * b[i__ + k *
|
||||
b_dim1];
|
||||
// L270:
|
||||
}
|
||||
}
|
||||
// L280:
|
||||
}
|
||||
temp = *alpha;
|
||||
if (nounit) {
|
||||
temp *= a[k + k * a_dim1];
|
||||
}
|
||||
if (temp != 1.) {
|
||||
i__1 = *m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
|
||||
// L290:
|
||||
}
|
||||
}
|
||||
// L300:
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DTRMM .
|
||||
//
|
||||
} // dtrmm_
|
||||
|
||||
Vendored
+396
@@ -0,0 +1,396 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DTRMV
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX,LDA,N
|
||||
// CHARACTER DIAG,TRANS,UPLO
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A(LDA,*),X(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DTRMV performs one of the matrix-vector operations
|
||||
//>
|
||||
//> x := A*x, or x := A**T*x,
|
||||
//>
|
||||
//> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
//> upper or lower triangular matrix.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] UPLO
|
||||
//> \verbatim
|
||||
//> UPLO is CHARACTER*1
|
||||
//> On entry, UPLO specifies whether the matrix is an upper or
|
||||
//> lower triangular matrix as follows:
|
||||
//>
|
||||
//> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
//>
|
||||
//> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANS
|
||||
//> \verbatim
|
||||
//> TRANS is CHARACTER*1
|
||||
//> On entry, TRANS specifies the operation to be performed as
|
||||
//> follows:
|
||||
//>
|
||||
//> TRANS = 'N' or 'n' x := A*x.
|
||||
//>
|
||||
//> TRANS = 'T' or 't' x := A**T*x.
|
||||
//>
|
||||
//> TRANS = 'C' or 'c' x := A**T*x.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DIAG
|
||||
//> \verbatim
|
||||
//> DIAG is CHARACTER*1
|
||||
//> On entry, DIAG specifies whether or not A is unit
|
||||
//> triangular as follows:
|
||||
//>
|
||||
//> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
//>
|
||||
//> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
//> triangular.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> On entry, N specifies the order of the matrix A.
|
||||
//> N must be at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension ( LDA, N )
|
||||
//> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
//> upper triangular part of the array A must contain the upper
|
||||
//> triangular matrix and the strictly lower triangular part of
|
||||
//> A is not referenced.
|
||||
//> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
//> lower triangular part of the array A must contain the lower
|
||||
//> triangular matrix and the strictly upper triangular part of
|
||||
//> A is not referenced.
|
||||
//> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
//> A are not referenced either, but are assumed to be unity.
|
||||
//> \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, n ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION array, dimension at least
|
||||
//> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
//> Before entry, the incremented array X must contain the n
|
||||
//> element vector x. On exit, X is overwritten with the
|
||||
//> transformed 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
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \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 dtrmv_(char *uplo, char *trans, char *diag, int *n,
|
||||
double *a, int *lda, double *x, int *incx)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j, ix, jx, kx, info;
|
||||
double temp;
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
int nounit;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level2 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 ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
|
||||
// Function Body
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
|
||||
info = 1;
|
||||
} else if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans,
|
||||
"C")) {
|
||||
info = 2;
|
||||
} else if (! lsame_(diag, "U") && ! lsame_(diag, "N")) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*lda < max(1,*n)) {
|
||||
info = 6;
|
||||
} else if (*incx == 0) {
|
||||
info = 8;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DTRMV ", &info);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible.
|
||||
//
|
||||
if (*n == 0) {
|
||||
return 0;
|
||||
}
|
||||
nounit = lsame_(diag, "N");
|
||||
//
|
||||
// Set up the start point in X if the increment is not unity. This
|
||||
// will be ( N - 1 )*INCX too small for descending loops.
|
||||
//
|
||||
if (*incx <= 0) {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
} else if (*incx != 1) {
|
||||
kx = 1;
|
||||
}
|
||||
//
|
||||
// Start the operations. In this version the elements of A are
|
||||
// accessed sequentially with one pass through A.
|
||||
//
|
||||
if (lsame_(trans, "N")) {
|
||||
//
|
||||
// Form x := A*x.
|
||||
//
|
||||
if (lsame_(uplo, "U")) {
|
||||
if (*incx == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (x[j] != 0.) {
|
||||
temp = x[j];
|
||||
i__2 = j - 1;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
x[i__] += temp * a[i__ + j * a_dim1];
|
||||
// L10:
|
||||
}
|
||||
if (nounit) {
|
||||
x[j] *= a[j + j * a_dim1];
|
||||
}
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (x[jx] != 0.) {
|
||||
temp = x[jx];
|
||||
ix = kx;
|
||||
i__2 = j - 1;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
x[ix] += temp * a[i__ + j * a_dim1];
|
||||
ix += *incx;
|
||||
// L30:
|
||||
}
|
||||
if (nounit) {
|
||||
x[jx] *= a[j + j * a_dim1];
|
||||
}
|
||||
}
|
||||
jx += *incx;
|
||||
// L40:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
if (x[j] != 0.) {
|
||||
temp = x[j];
|
||||
i__1 = j + 1;
|
||||
for (i__ = *n; i__ >= i__1; --i__) {
|
||||
x[i__] += temp * a[i__ + j * a_dim1];
|
||||
// L50:
|
||||
}
|
||||
if (nounit) {
|
||||
x[j] *= a[j + j * a_dim1];
|
||||
}
|
||||
}
|
||||
// L60:
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
if (x[jx] != 0.) {
|
||||
temp = x[jx];
|
||||
ix = kx;
|
||||
i__1 = j + 1;
|
||||
for (i__ = *n; i__ >= i__1; --i__) {
|
||||
x[ix] += temp * a[i__ + j * a_dim1];
|
||||
ix -= *incx;
|
||||
// L70:
|
||||
}
|
||||
if (nounit) {
|
||||
x[jx] *= a[j + j * a_dim1];
|
||||
}
|
||||
}
|
||||
jx -= *incx;
|
||||
// L80:
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form x := A**T*x.
|
||||
//
|
||||
if (lsame_(uplo, "U")) {
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
temp = x[j];
|
||||
if (nounit) {
|
||||
temp *= a[j + j * a_dim1];
|
||||
}
|
||||
for (i__ = j - 1; i__ >= 1; --i__) {
|
||||
temp += a[i__ + j * a_dim1] * x[i__];
|
||||
// L90:
|
||||
}
|
||||
x[j] = temp;
|
||||
// L100:
|
||||
}
|
||||
} else {
|
||||
jx = kx + (*n - 1) * *incx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
temp = x[jx];
|
||||
ix = jx;
|
||||
if (nounit) {
|
||||
temp *= a[j + j * a_dim1];
|
||||
}
|
||||
for (i__ = j - 1; i__ >= 1; --i__) {
|
||||
ix -= *incx;
|
||||
temp += a[i__ + j * a_dim1] * x[ix];
|
||||
// L110:
|
||||
}
|
||||
x[jx] = temp;
|
||||
jx -= *incx;
|
||||
// L120:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp = x[j];
|
||||
if (nounit) {
|
||||
temp *= a[j + j * a_dim1];
|
||||
}
|
||||
i__2 = *n;
|
||||
for (i__ = j + 1; i__ <= i__2; ++i__) {
|
||||
temp += a[i__ + j * a_dim1] * x[i__];
|
||||
// L130:
|
||||
}
|
||||
x[j] = temp;
|
||||
// L140:
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp = x[jx];
|
||||
ix = jx;
|
||||
if (nounit) {
|
||||
temp *= a[j + j * a_dim1];
|
||||
}
|
||||
i__2 = *n;
|
||||
for (i__ = j + 1; i__ <= i__2; ++i__) {
|
||||
ix += *incx;
|
||||
temp += a[i__ + j * a_dim1] * x[ix];
|
||||
// L150:
|
||||
}
|
||||
x[jx] = temp;
|
||||
jx += *incx;
|
||||
// L160:
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DTRMV .
|
||||
//
|
||||
} // dtrmv_
|
||||
|
||||
Vendored
+1334
File diff suppressed because it is too large
Load Diff
Vendored
+444
@@ -0,0 +1,444 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b SGEMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// REAL ALPHA,BETA
|
||||
// INTEGER K,LDA,LDB,LDC,M,N
|
||||
// CHARACTER TRANSA,TRANSB
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// REAL A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> SGEMM 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 REAL
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is REAL 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 REAL 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 REAL
|
||||
//> 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 REAL 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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup single_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 sgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, float *alpha, float *a, int *lda, float *b, int *ldb, float *beta,
|
||||
float *c__, int *ldc)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
|
||||
i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
float temp;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 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 ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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, NCOLA and NROWB as the number of rows
|
||||
// and columns of A and the number of rows of B respectively.
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
b_dim1 = *ldb;
|
||||
b_offset = 1 + b_dim1;
|
||||
b -= b_offset;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
|
||||
// Function Body
|
||||
nota = lsame_(transa, "N");
|
||||
notb = lsame_(transb, "N");
|
||||
if (nota) {
|
||||
nrowa = *m;
|
||||
ncola = *k;
|
||||
} else {
|
||||
nrowa = *k;
|
||||
ncola = *m;
|
||||
}
|
||||
if (notb) {
|
||||
nrowb = *k;
|
||||
} else {
|
||||
nrowb = *n;
|
||||
}
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
info = 0;
|
||||
if (! nota && ! lsame_(transa, "C") && ! lsame_(transa, "T")) {
|
||||
info = 1;
|
||||
} else if (! notb && ! lsame_(transb, "C") && ! lsame_(transb, "T")) {
|
||||
info = 2;
|
||||
} else if (*m < 0) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < max(1,nrowa)) {
|
||||
info = 8;
|
||||
} else if (*ldb < max(1,nrowb)) {
|
||||
info = 10;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
info = 13;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("SGEMM ", &info);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible.
|
||||
//
|
||||
if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// And if alpha.eq.zero.
|
||||
//
|
||||
if (*alpha == 0.f) {
|
||||
if (*beta == 0.f) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] = 0.f;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
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.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] = 0.f;
|
||||
// L50:
|
||||
}
|
||||
} else if (*beta != 1.f) {
|
||||
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;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
temp = *alpha * b[l + j * b_dim1];
|
||||
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;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp = 0.f;
|
||||
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.f) {
|
||||
c__[i__ + j * c_dim1] = *alpha * temp;
|
||||
} else {
|
||||
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.f) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] = 0.f;
|
||||
// L130:
|
||||
}
|
||||
} else if (*beta != 1.f) {
|
||||
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;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
temp = *alpha * b[j + l * b_dim1];
|
||||
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;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp = 0.f;
|
||||
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.f) {
|
||||
c__[i__ + j * c_dim1] = *alpha * temp;
|
||||
} else {
|
||||
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
|
||||
i__ + j * c_dim1];
|
||||
}
|
||||
// L190:
|
||||
}
|
||||
// L200:
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of SGEMM .
|
||||
//
|
||||
} // sgemm_
|
||||
|
||||
Vendored
+752
@@ -0,0 +1,752 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b ZGEMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// COMPLEX*16 ALPHA,BETA
|
||||
// INTEGER K,LDA,LDB,LDC,M,N
|
||||
// CHARACTER TRANSA,TRANSB
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> ZGEMM 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 or op( X ) = X**H,
|
||||
//>
|
||||
//> 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**H.
|
||||
//> \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**H.
|
||||
//> \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 COMPLEX*16
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is COMPLEX*16 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 COMPLEX*16 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 COMPLEX*16
|
||||
//> 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 COMPLEX*16 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.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup complex16_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 zgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, doublecomplex *alpha, doublecomplex *a, int *lda, doublecomplex *b,
|
||||
int *ldb, doublecomplex *beta, doublecomplex *c__, int *ldc)
|
||||
{
|
||||
// Table of constant values
|
||||
doublecomplex c_b1 = {1.,0.};
|
||||
doublecomplex c_b2 = {0.,0.};
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
|
||||
i__3, i__4, i__5, i__6;
|
||||
doublecomplex z__1, z__2, z__3, z__4;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
doublecomplex temp;
|
||||
int conja, conjb;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 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 ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
//
|
||||
// Set NOTA and NOTB as true if A and B respectively are not
|
||||
// conjugated or transposed, set CONJA and CONJB as true if A and
|
||||
// B respectively are to be transposed but not conjugated and set
|
||||
// NROWA, NCOLA and NROWB as the number of rows and columns of A
|
||||
// and the number of rows of B respectively.
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
b_dim1 = *ldb;
|
||||
b_offset = 1 + b_dim1;
|
||||
b -= b_offset;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
|
||||
// Function Body
|
||||
nota = lsame_(transa, "N");
|
||||
notb = lsame_(transb, "N");
|
||||
conja = lsame_(transa, "C");
|
||||
conjb = lsame_(transb, "C");
|
||||
if (nota) {
|
||||
nrowa = *m;
|
||||
ncola = *k;
|
||||
} else {
|
||||
nrowa = *k;
|
||||
ncola = *m;
|
||||
}
|
||||
if (notb) {
|
||||
nrowb = *k;
|
||||
} else {
|
||||
nrowb = *n;
|
||||
}
|
||||
//
|
||||
// Test the input parameters.
|
||||
//
|
||||
info = 0;
|
||||
if (! nota && ! conja && ! lsame_(transa, "T")) {
|
||||
info = 1;
|
||||
} else if (! notb && ! conjb && ! lsame_(transb, "T")) {
|
||||
info = 2;
|
||||
} else if (*m < 0) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < max(1,nrowa)) {
|
||||
info = 8;
|
||||
} else if (*ldb < max(1,nrowb)) {
|
||||
info = 10;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
info = 13;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("ZGEMM ", &info);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible.
|
||||
//
|
||||
if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) &&
|
||||
(beta->r == 1. && beta->i == 0.)) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// And when alpha.eq.zero.
|
||||
//
|
||||
if (alpha->r == 0. && alpha->i == 0.) {
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0., c__[i__3].i = 0.;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
|
||||
z__1.i = beta->r * c__[i__4].i + beta->i * c__[
|
||||
i__4].r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
// 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->r == 0. && beta->i == 0.) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0., c__[i__3].i = 0.;
|
||||
// L50:
|
||||
}
|
||||
} else if (beta->r != 1. || beta->i != 0.) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
// L60:
|
||||
}
|
||||
}
|
||||
i__2 = *k;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
i__3 = l + j * b_dim1;
|
||||
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
|
||||
z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
|
||||
.r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__ + j * c_dim1;
|
||||
i__5 = i__ + j * c_dim1;
|
||||
i__6 = i__ + l * a_dim1;
|
||||
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
|
||||
z__2.i = temp.r * a[i__6].i + temp.i * a[i__6]
|
||||
.r;
|
||||
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
|
||||
z__2.i;
|
||||
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
|
||||
// L70:
|
||||
}
|
||||
// L80:
|
||||
}
|
||||
// L90:
|
||||
}
|
||||
} else if (conja) {
|
||||
//
|
||||
// Form C := alpha*A**H*B + beta*C.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0., temp.i = 0.;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
|
||||
i__4 = l + j * b_dim1;
|
||||
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
|
||||
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
|
||||
.r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
// L100:
|
||||
}
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
}
|
||||
// L110:
|
||||
}
|
||||
// L120:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A**T*B + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0., temp.i = 0.;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
i__4 = l + i__ * a_dim1;
|
||||
i__5 = l + j * b_dim1;
|
||||
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
|
||||
.i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
|
||||
.i * b[i__5].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
// L130:
|
||||
}
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
}
|
||||
// L140:
|
||||
}
|
||||
// L150:
|
||||
}
|
||||
}
|
||||
} else if (nota) {
|
||||
if (conjb) {
|
||||
//
|
||||
// Form C := alpha*A*B**H + beta*C.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0., c__[i__3].i = 0.;
|
||||
// L160:
|
||||
}
|
||||
} else if (beta->r != 1. || beta->i != 0.) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
// L170:
|
||||
}
|
||||
}
|
||||
i__2 = *k;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
d_cnjg(&z__2, &b[j + l * b_dim1]);
|
||||
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
|
||||
alpha->r * z__2.i + alpha->i * z__2.r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__ + j * c_dim1;
|
||||
i__5 = i__ + j * c_dim1;
|
||||
i__6 = i__ + l * a_dim1;
|
||||
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
|
||||
z__2.i = temp.r * a[i__6].i + temp.i * a[i__6]
|
||||
.r;
|
||||
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
|
||||
z__2.i;
|
||||
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
|
||||
// L180:
|
||||
}
|
||||
// L190:
|
||||
}
|
||||
// L200:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A*B**T + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
c__[i__3].r = 0., c__[i__3].i = 0.;
|
||||
// L210:
|
||||
}
|
||||
} else if (beta->r != 1. || beta->i != 0.) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
// L220:
|
||||
}
|
||||
}
|
||||
i__2 = *k;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
i__3 = j + l * b_dim1;
|
||||
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
|
||||
z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
|
||||
.r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
i__3 = *m;
|
||||
for (i__ = 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__ + j * c_dim1;
|
||||
i__5 = i__ + j * c_dim1;
|
||||
i__6 = i__ + l * a_dim1;
|
||||
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
|
||||
z__2.i = temp.r * a[i__6].i + temp.i * a[i__6]
|
||||
.r;
|
||||
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
|
||||
z__2.i;
|
||||
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
|
||||
// L230:
|
||||
}
|
||||
// L240:
|
||||
}
|
||||
// L250:
|
||||
}
|
||||
}
|
||||
} else if (conja) {
|
||||
if (conjb) {
|
||||
//
|
||||
// Form C := alpha*A**H*B**H + beta*C.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0., temp.i = 0.;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
|
||||
d_cnjg(&z__4, &b[j + l * b_dim1]);
|
||||
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i =
|
||||
z__3.r * z__4.i + z__3.i * z__4.r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
// L260:
|
||||
}
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
}
|
||||
// L270:
|
||||
}
|
||||
// L280:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A**H*B**T + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0., temp.i = 0.;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
|
||||
i__4 = j + l * b_dim1;
|
||||
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
|
||||
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
|
||||
.r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
// L290:
|
||||
}
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
}
|
||||
// L300:
|
||||
}
|
||||
// L310:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (conjb) {
|
||||
//
|
||||
// Form C := alpha*A**T*B**H + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0., temp.i = 0.;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
i__4 = l + i__ * a_dim1;
|
||||
d_cnjg(&z__3, &b[j + l * b_dim1]);
|
||||
z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i,
|
||||
z__2.i = a[i__4].r * z__3.i + a[i__4].i *
|
||||
z__3.r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
// L320:
|
||||
}
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
}
|
||||
// L330:
|
||||
}
|
||||
// L340:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C := alpha*A**T*B**T + beta*C
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp.r = 0., temp.i = 0.;
|
||||
i__3 = *k;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
i__4 = l + i__ * a_dim1;
|
||||
i__5 = j + l * b_dim1;
|
||||
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
|
||||
.i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
|
||||
.i * b[i__5].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
// L350:
|
||||
}
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__1.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
} else {
|
||||
i__3 = i__ + j * c_dim1;
|
||||
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
|
||||
z__2.i = alpha->r * temp.i + alpha->i *
|
||||
temp.r;
|
||||
i__4 = i__ + j * c_dim1;
|
||||
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
|
||||
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
|
||||
c__[i__4].r;
|
||||
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
|
||||
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
|
||||
}
|
||||
// L360:
|
||||
}
|
||||
// L370:
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of ZGEMM .
|
||||
//
|
||||
} // zgemm_
|
||||
|
||||
Reference in New Issue
Block a user