GitHub-Proxy/eigen
1
0
Fork 0
mirror of https://gitlab.com/libeigen/eigen.git synced 2025-07-21 12:24:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

Apply clang-format to lapack/blas directories

Browse Source
This commit is contained in:
Antonio Sanchez 2024-02-09 10:32:56 -08:00 committed by Antonio Sánchez
parent 4eac211e96
commit 186f8205db
24 changed files with 5720 additions and 6027 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

853
blas/f2c/chbmv.c
View File

@ -1,487 +1,456 @@
/* chbmv.f -- translated by f2c (version 20100827). /* chbmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex * /* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex *alpha, complex *a, integer *lda, complex *x,
alpha, complex *a, integer *lda, complex *x, integer *incx, complex * integer *incx, complex *beta, complex *y, integer *incy, ftnlen uplo_len) {
beta, complex *y, integer *incy, ftnlen uplo_len) /* System generated locals */
{ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* System generated locals */ real r__1;
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; complex q__1, q__2, q__3, q__4;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */ /* Builtin functions */
void r_cnjg(complex *, complex *); void r_cnjg(complex *, complex *);
/* Local variables */ /* Local variables */
integer i__, j, l, ix, iy, jx, jy, kx, ky, info; integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
complex temp1, temp2; complex temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kplus1; integer kplus1;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* CHBMV performs the matrix-vector operation */ /* CHBMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n hermitian band matrix, with k super-diagonals. */ /* A is an n by n hermitian band matrix, with k super-diagonals. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the band matrix A is being supplied as */ /* triangular part of the band matrix A is being supplied as */
/* follows: */ /* follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* being supplied. */ /* being supplied. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* being supplied. */ /* being supplied. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* K - INTEGER. */ /* K - INTEGER. */
/* On entry, K specifies the number of super-diagonals of the */ /* On entry, K specifies the number of super-diagonals of the */
/* matrix A. K must satisfy 0 .le. K. */ /* matrix A. K must satisfy 0 .le. K. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - COMPLEX . */ /* ALPHA - COMPLEX . */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* A - COMPLEX array of DIMENSION ( LDA, n ). */ /* A - COMPLEX array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ /* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
/* by n part of the array A must contain the upper triangular */ /* by n part of the array A must contain the upper triangular */
/* band part of the hermitian matrix, supplied column by */ /* band part of the hermitian matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row */ /* column, with the leading diagonal of the matrix in row */
/* ( k + 1 ) of the array, the first super-diagonal starting at */ /* ( k + 1 ) of the array, the first super-diagonal starting at */
/* position 2 in row k, and so on. The top left k by k triangle */ /* position 2 in row k, and so on. The top left k by k triangle */
/* of the array A is not referenced. */ /* of the array A is not referenced. */
/* The following program segment will transfer the upper */ /* The following program segment will transfer the upper */
/* triangular part of a hermitian band matrix from conventional */ /* triangular part of a hermitian band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = K + 1 - J */ /* M = K + 1 - J */
/* DO 10, I = MAX( 1, J - K ), J */ /* DO 10, I = MAX( 1, J - K ), J */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ /* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
/* by n part of the array A must contain the lower triangular */ /* by n part of the array A must contain the lower triangular */
/* band part of the hermitian matrix, supplied column by */ /* band part of the hermitian matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row 1 of */ /* column, with the leading diagonal of the matrix in row 1 of */
/* the array, the first sub-diagonal starting at position 1 in */ /* the array, the first sub-diagonal starting at position 1 in */
/* row 2, and so on. The bottom right k by k triangle of the */ /* row 2, and so on. The bottom right k by k triangle of the */
/* array A is not referenced. */ /* array A is not referenced. */
/* The following program segment will transfer the lower */ /* The following program segment will transfer the lower */
/* triangular part of a hermitian band matrix from conventional */ /* triangular part of a hermitian band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = 1 - J */ /* M = 1 - J */
/* DO 10, I = J, MIN( N, J + K ) */ /* DO 10, I = J, MIN( N, J + K ) */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Note that the imaginary parts of the diagonal elements need */ /* Note that the imaginary parts of the diagonal elements need */
/* not be set and are assumed to be zero. */ /* not be set and are assumed to be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* LDA - INTEGER. */ /* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */ /* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */ /* in the calling (sub) program. LDA must be at least */
/* ( k + 1 ). */ /* ( k + 1 ). */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - COMPLEX array of DIMENSION at least */ /* X - COMPLEX array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the */ /* Before entry, the incremented array X must contain the */
/* vector x. */ /* vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - COMPLEX . */ /* BETA - COMPLEX . */
/* On entry, BETA specifies the scalar beta. */ /* On entry, BETA specifies the scalar beta. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - COMPLEX array of DIMENSION at least */ /* Y - COMPLEX array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the */ /* Before entry, the incremented array Y must contain the */
/* vector y. On exit, Y is overwritten by the updated vector y. */ /* vector y. On exit, Y is overwritten by the updated vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
a_dim1 = *lda; a_dim1 = *lda;
a_offset = 1 + a_dim1; a_offset = 1 + a_dim1;
a -= a_offset; a -= a_offset;
--x; --x;
--y; --y;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("CHBMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
beta->i == 0.f))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (beta->r != 1.f || beta->i != 0.f) {
if (*incy == 1) {
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0.f, y[i__2].i = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0.f && alpha->i == 0.f) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = i__;
i__3 = i__;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__2 = i__;
q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i =
q__3.r * x[i__2].i + q__3.i * x[i__2].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L50: */
}
i__4 = j;
i__2 = j;
i__3 = kplus1 + j * a_dim1;
r__1 = a[i__3].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = jx;
q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i =
alpha->r * x[i__4].i + alpha->i * x[i__4].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__3 = jy;
i__4 = jy;
i__2 = kplus1 + j * a_dim1;
r__1 = a[i__2].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = j;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = j;
i__4 = j;
i__2 = j * a_dim1 + 1;
r__1 = a[i__2].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__2 = i__;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L90: */
}
i__3 = j;
i__4 = j;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = jx;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = jy;
i__4 = jy;
i__2 = j * a_dim1 + 1;
r__1 = a[i__2].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L110: */
}
i__3 = jy;
i__4 = jy;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("CHBMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of CHBMV . */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && beta->i == 0.f))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (beta->r != 1.f || beta->i != 0.f) {
if (*incy == 1) {
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, q__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0.f, y[i__2].i = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, q__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0.f && alpha->i == 0.f) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
i__2 = i__;
i__3 = i__;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__2 = i__;
q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i = q__3.r * x[i__2].i + q__3.i * x[i__2].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L50: */
}
i__4 = j;
i__2 = j;
i__3 = kplus1 + j * a_dim1;
r__1 = a[i__3].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = jx;
q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i = alpha->r * x[i__4].i + alpha->i * x[i__4].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__3 = jy;
i__4 = jy;
i__2 = kplus1 + j * a_dim1;
r__1 = a[i__2].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = j;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = j;
i__4 = j;
i__2 = j * a_dim1 + 1;
r__1 = a[i__2].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__2 = i__;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L90: */
}
i__3 = j;
i__4 = j;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = jx;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = jy;
i__4 = jy;
i__2 = j * a_dim1 + 1;
r__1 = a[i__2].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L110: */
}
i__3 = jy;
i__4 = jy;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of CHBMV . */
} /* chbmv_ */ } /* chbmv_ */

767
blas/f2c/chpmv.c
View File

@ -1,438 +1,407 @@
/* chpmv.f -- translated by f2c (version 20100827). /* chpmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex * /* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex *ap, complex *x, integer *incx,
ap, complex *x, integer *incx, complex *beta, complex *y, integer * complex *beta, complex *y, integer *incy, ftnlen uplo_len) {
incy, ftnlen uplo_len) /* System generated locals */
{ integer i__1, i__2, i__3, i__4, i__5;
/* System generated locals */ real r__1;
integer i__1, i__2, i__3, i__4, i__5; complex q__1, q__2, q__3, q__4;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */ /* Builtin functions */
void r_cnjg(complex *, complex *); void r_cnjg(complex *, complex *);
/* Local variables */ /* Local variables */
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
complex temp1, temp2; complex temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* CHPMV performs the matrix-vector operation */ /* CHPMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n hermitian matrix, supplied in packed form. */ /* A is an n by n hermitian matrix, supplied in packed form. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the matrix A is supplied in the packed */ /* triangular part of the matrix A is supplied in the packed */
/* array AP as follows: */ /* array AP as follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - COMPLEX . */ /* ALPHA - COMPLEX . */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* AP - COMPLEX array of DIMENSION at least */ /* AP - COMPLEX array of DIMENSION at least */
/* ( ( n*( n + 1 ) )/2 ). */ /* ( ( n*( n + 1 ) )/2 ). */
/* Before entry with UPLO = 'U' or 'u', the array AP must */ /* Before entry with UPLO = 'U' or 'u', the array AP must */
/* contain the upper triangular part of the hermitian matrix */ /* contain the upper triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
/* and a( 2, 2 ) respectively, and so on. */ /* and a( 2, 2 ) respectively, and so on. */
/* Before entry with UPLO = 'L' or 'l', the array AP must */ /* Before entry with UPLO = 'L' or 'l', the array AP must */
/* contain the lower triangular part of the hermitian matrix */ /* contain the lower triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
/* and a( 3, 1 ) respectively, and so on. */ /* and a( 3, 1 ) respectively, and so on. */
/* Note that the imaginary parts of the diagonal elements need */ /* Note that the imaginary parts of the diagonal elements need */
/* not be set and are assumed to be zero. */ /* not be set and are assumed to be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - COMPLEX array of dimension at least */ /* X - COMPLEX array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */ /* Before entry, the incremented array X must contain the n */
/* element vector x. */ /* element vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - COMPLEX . */ /* BETA - COMPLEX . */
/* On entry, BETA specifies the scalar beta. When BETA is */ /* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */ /* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - COMPLEX array of dimension at least */ /* Y - COMPLEX array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the n */ /* Before entry, the incremented array Y must contain the n */
/* element vector y. On exit, Y is overwritten by the updated */ /* element vector y. On exit, Y is overwritten by the updated */
/* vector y. */ /* vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
--y; --y;
--x; --x;
--ap; --ap;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("CHPMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
beta->i == 0.f))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (beta->r != 1.f || beta->i != 0.f) {
if (*incy == 1) {
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0.f, y[i__2].i = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0.f && alpha->i == 0.f) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = i__;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
++k;
/* L50: */
}
i__2 = j;
i__3 = j;
i__4 = kk + j - 1;
r__1 = ap[i__4].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
i__3 = iy;
i__4 = iy;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = ix;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__2 = jy;
i__3 = jy;
i__4 = kk + j - 1;
r__1 = ap[i__4].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__2 = j;
i__3 = j;
i__4 = kk;
r__1 = ap[i__4].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = i__;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
++k;
/* L90: */
}
i__2 = j;
i__3 = j;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__2 = jy;
i__3 = jy;
i__4 = kk;
r__1 = ap[i__4].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
i__3 = iy;
i__4 = iy;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = ix;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L110: */
}
i__2 = jy;
i__3 = jy;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("CHPMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of CHPMV . */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && beta->i == 0.f))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (beta->r != 1.f || beta->i != 0.f) {
if (*incy == 1) {
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, q__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0.f, y[i__2].i = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, q__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0.f && alpha->i == 0.f) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = i__;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
++k;
/* L50: */
}
i__2 = j;
i__3 = j;
i__4 = kk + j - 1;
r__1 = ap[i__4].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
i__3 = iy;
i__4 = iy;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = ix;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__2 = jy;
i__3 = jy;
i__4 = kk + j - 1;
r__1 = ap[i__4].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__2 = j;
i__3 = j;
i__4 = kk;
r__1 = ap[i__4].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = i__;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
++k;
/* L90: */
}
i__2 = j;
i__3 = j;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__2 = jy;
i__3 = jy;
i__4 = kk;
r__1 = ap[i__4].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
i__3 = iy;
i__4 = iy;
i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]);
i__3 = ix;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L110: */
}
i__2 = jy;
i__3 = jy;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
return 0;
/* End of CHPMV . */
} /* chpmv_ */ } /* chpmv_ */

101
blas/f2c/complexdots.c
View File

@ -6,79 +6,68 @@
/* complexdots.f -- translated by f2c (version 20100827). /* complexdots.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
complex cdotc_(integer *n, complex *cx, integer complex cdotc_(integer *n, complex *cx, integer *incx, complex *cy, integer *incy) {
*incx, complex *cy, integer *incy) complex res;
{ extern /* Subroutine */ int cdotcw_(integer *, complex *, integer *, complex *, integer *, complex *);
complex res;
extern /* Subroutine */ int cdotcw_(integer *, complex *, integer *,
complex *, integer *, complex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
--cx; --cx;
/* Function Body */ /* Function Body */
cdotcw_(n, &cx[1], incx, &cy[1], incy, &res); cdotcw_(n, &cx[1], incx, &cy[1], incy, &res);
return res; return res;
} /* cdotc_ */ } /* cdotc_ */
complex cdotu_(integer *n, complex *cx, integer complex cdotu_(integer *n, complex *cx, integer *incx, complex *cy, integer *incy) {
*incx, complex *cy, integer *incy) complex res;
{ extern /* Subroutine */ int cdotuw_(integer *, complex *, integer *, complex *, integer *, complex *);
complex res;
extern /* Subroutine */ int cdotuw_(integer *, complex *, integer *,
complex *, integer *, complex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
--cx; --cx;
/* Function Body */ /* Function Body */
cdotuw_(n, &cx[1], incx, &cy[1], incy, &res); cdotuw_(n, &cx[1], incx, &cy[1], incy, &res);
return res; return res;
} /* cdotu_ */ } /* cdotu_ */
doublecomplex zdotc_(integer *n, doublecomplex *cx, integer *incx, doublecomplex zdotc_(integer *n, doublecomplex *cx, integer *incx, doublecomplex *cy, integer *incy) {
doublecomplex *cy, integer *incy) doublecomplex res;
{ extern /* Subroutine */ int zdotcw_(integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex res; doublecomplex *);
extern /* Subroutine */ int zdotcw_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
--cx; --cx;
/* Function Body */ /* Function Body */
zdotcw_(n, &cx[1], incx, &cy[1], incy, &res); zdotcw_(n, &cx[1], incx, &cy[1], incy, &res);
return res; return res;
} /* zdotc_ */ } /* zdotc_ */
doublecomplex zdotu_(integer *n, doublecomplex *cx, integer *incx, doublecomplex zdotu_(integer *n, doublecomplex *cx, integer *incx, doublecomplex *cy, integer *incy) {
doublecomplex *cy, integer *incy) doublecomplex res;
{ extern /* Subroutine */ int zdotuw_(integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex res; doublecomplex *);
extern /* Subroutine */ int zdotuw_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
--cx; --cx;
/* Function Body */ /* Function Body */
zdotuw_(n, &cx[1], incx, &cy[1], incy, &res); zdotuw_(n, &cx[1], incx, &cy[1], incy, &res);
return res; return res;
} /* zdotu_ */ } /* zdotu_ */

1134
blas/f2c/ctbmv.c
View File

File diff suppressed because it is too large Load Diff

6
blas/f2c/d_cnjg.c
View File

@ -1,6 +1,6 @@
#include "datatypes.h" #include "datatypes.h"
void d_cnjg(doublecomplex *r, doublecomplex *z) { void d_cnjg(doublecomplex *r, doublecomplex *z) {
r->r = z->r; r->r = z->r;
r->i = -(z->i); r->i = -(z->i);
} }

350
blas/f2c/drotm.c
View File

@ -1,215 +1,213 @@
/* drotm.f -- translated by f2c (version 20100827). /* drotm.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, /* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy,
doublereal *dy, integer *incy, doublereal *dparam) doublereal *dparam) {
{ /* Initialized data */
/* Initialized data */
static doublereal zero = 0.; static doublereal zero = 0.;
static doublereal two = 2.; static doublereal two = 2.;
/* System generated locals */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
/* Local variables */ /* Local variables */
integer i__; integer i__;
doublereal w, z__; doublereal w, z__;
integer kx, ky; integer kx, ky;
doublereal dh11, dh12, dh21, dh22, dflag; doublereal dh11, dh12, dh21, dh22, dflag;
integer nsteps; integer nsteps;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ /* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */ /* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */
/* (DY**T) */ /* (DY**T) */
/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ /* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */ /* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */
/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ /* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ /* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ /* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
/* H=( ) ( ) ( ) ( ) */ /* H=( ) ( ) ( ) ( ) */
/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ /* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */ /* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */
/* Arguments */ /* Arguments */
/* ========= */ /* ========= */
/* N (input) INTEGER */ /* N (input) INTEGER */
/* number of elements in input vector(s) */ /* number of elements in input vector(s) */
/* DX (input/output) DOUBLE PRECISION array, dimension N */ /* DX (input/output) DOUBLE PRECISION array, dimension N */
/* double precision vector with N elements */ /* double precision vector with N elements */
/* INCX (input) INTEGER */ /* INCX (input) INTEGER */
/* storage spacing between elements of DX */ /* storage spacing between elements of DX */
/* DY (input/output) DOUBLE PRECISION array, dimension N */ /* DY (input/output) DOUBLE PRECISION array, dimension N */
/* double precision vector with N elements */ /* double precision vector with N elements */
/* INCY (input) INTEGER */ /* INCY (input) INTEGER */
/* storage spacing between elements of DY */ /* storage spacing between elements of DY */
/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ /* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */
/* DPARAM(1)=DFLAG */ /* DPARAM(1)=DFLAG */
/* DPARAM(2)=DH11 */ /* DPARAM(2)=DH11 */
/* DPARAM(3)=DH21 */ /* DPARAM(3)=DH21 */
/* DPARAM(4)=DH12 */ /* DPARAM(4)=DH12 */
/* DPARAM(5)=DH22 */ /* DPARAM(5)=DH22 */
/* ===================================================================== */ /* ===================================================================== */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. Data statements .. */ /* .. Data statements .. */
/* Parameter adjustments */ /* Parameter adjustments */
--dparam; --dparam;
--dy; --dy;
--dx; --dx;
/* Function Body */ /* Function Body */
/* .. */ /* .. */
dflag = dparam[1]; dflag = dparam[1];
if (*n <= 0 || dflag + two == zero) { if (*n <= 0 || dflag + two == zero) {
goto L140; goto L140;
} }
if (! (*incx == *incy && *incx > 0)) { if (!(*incx == *incy && *incx > 0)) {
goto L70; goto L70;
} }
nsteps = *n * *incx; nsteps = *n * *incx;
if (dflag < 0.) { if (dflag < 0.) {
goto L50; goto L50;
} else if (dflag == 0) { } else if (dflag == 0) {
goto L10; goto L10;
} else { } else {
goto L30; goto L30;
} }
L10: L10:
dh12 = dparam[4]; dh12 = dparam[4];
dh21 = dparam[3]; dh21 = dparam[3];
i__1 = nsteps; i__1 = nsteps;
i__2 = *incx; i__2 = *incx;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
w = dx[i__]; w = dx[i__];
z__ = dy[i__]; z__ = dy[i__];
dx[i__] = w + z__ * dh12; dx[i__] = w + z__ * dh12;
dy[i__] = w * dh21 + z__; dy[i__] = w * dh21 + z__;
/* L20: */ /* L20: */
} }
goto L140; goto L140;
L30: L30:
dh11 = dparam[2]; dh11 = dparam[2];
dh22 = dparam[5]; dh22 = dparam[5];
i__2 = nsteps; i__2 = nsteps;
i__1 = *incx; i__1 = *incx;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
w = dx[i__]; w = dx[i__];
z__ = dy[i__]; z__ = dy[i__];
dx[i__] = w * dh11 + z__; dx[i__] = w * dh11 + z__;
dy[i__] = -w + dh22 * z__; dy[i__] = -w + dh22 * z__;
/* L40: */ /* L40: */
} }
goto L140; goto L140;
L50: L50:
dh11 = dparam[2]; dh11 = dparam[2];
dh12 = dparam[4]; dh12 = dparam[4];
dh21 = dparam[3]; dh21 = dparam[3];
dh22 = dparam[5]; dh22 = dparam[5];
i__1 = nsteps; i__1 = nsteps;
i__2 = *incx; i__2 = *incx;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
w = dx[i__]; w = dx[i__];
z__ = dy[i__]; z__ = dy[i__];
dx[i__] = w * dh11 + z__ * dh12; dx[i__] = w * dh11 + z__ * dh12;
dy[i__] = w * dh21 + z__ * dh22; dy[i__] = w * dh21 + z__ * dh22;
/* L60: */ /* L60: */
} }
goto L140; goto L140;
L70: L70:
kx = 1; kx = 1;
ky = 1; ky = 1;
if (*incx < 0) { if (*incx < 0) {
kx = (1 - *n) * *incx + 1; kx = (1 - *n) * *incx + 1;
} }
if (*incy < 0) { if (*incy < 0) {
ky = (1 - *n) * *incy + 1; ky = (1 - *n) * *incy + 1;
} }
if (dflag < 0.) { if (dflag < 0.) {
goto L120; goto L120;
} else if (dflag == 0) { } else if (dflag == 0) {
goto L80; goto L80;
} else { } else {
goto L100; goto L100;
} }
L80: L80:
dh12 = dparam[4]; dh12 = dparam[4];
dh21 = dparam[3]; dh21 = dparam[3];
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w = dx[kx]; w = dx[kx];
z__ = dy[ky]; z__ = dy[ky];
dx[kx] = w + z__ * dh12; dx[kx] = w + z__ * dh12;
dy[ky] = w * dh21 + z__; dy[ky] = w * dh21 + z__;
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
/* L90: */ /* L90: */
} }
goto L140; goto L140;
L100: L100:
dh11 = dparam[2]; dh11 = dparam[2];
dh22 = dparam[5]; dh22 = dparam[5];
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w = dx[kx]; w = dx[kx];
z__ = dy[ky]; z__ = dy[ky];
dx[kx] = w * dh11 + z__; dx[kx] = w * dh11 + z__;
dy[ky] = -w + dh22 * z__; dy[ky] = -w + dh22 * z__;
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
/* L110: */ /* L110: */
} }
goto L140; goto L140;
L120: L120:
dh11 = dparam[2]; dh11 = dparam[2];
dh12 = dparam[4]; dh12 = dparam[4];
dh21 = dparam[3]; dh21 = dparam[3];
dh22 = dparam[5]; dh22 = dparam[5];
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w = dx[kx]; w = dx[kx];
z__ = dy[ky]; z__ = dy[ky];
dx[kx] = w * dh11 + z__ * dh12; dx[kx] = w * dh11 + z__ * dh12;
dy[ky] = w * dh21 + z__ * dh22; dy[ky] = w * dh21 + z__ * dh22;
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
/* L130: */ /* L130: */
} }
L140: L140:
return 0; return 0;
} /* drotm_ */ } /* drotm_ */

458
blas/f2c/drotmg.c
View File

@ -1,293 +1,293 @@
/* drotmg.f -- translated by f2c (version 20100827). /* drotmg.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal * /* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal *dx1, doublereal *dy1, doublereal *dparam) {
dx1, doublereal *dy1, doublereal *dparam) /* Initialized data */
{
/* Initialized data */
static doublereal zero = 0.; static doublereal zero = 0.;
static doublereal one = 1.; static doublereal one = 1.;
static doublereal two = 2.; static doublereal two = 2.;
static doublereal gam = 4096.; static doublereal gam = 4096.;
static doublereal gamsq = 16777216.; static doublereal gamsq = 16777216.;
static doublereal rgamsq = 5.9604645e-8; static doublereal rgamsq = 5.9604645e-8;
/* Format strings */ /* Format strings */
static char fmt_120[] = ""; static char fmt_120[] = "";
static char fmt_150[] = ""; static char fmt_150[] = "";
static char fmt_180[] = ""; static char fmt_180[] = "";
static char fmt_210[] = ""; static char fmt_210[] = "";
/* System generated locals */ /* System generated locals */
doublereal d__1; doublereal d__1;
/* Local variables */ /* Local variables */
doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22; doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22;
integer igo; integer igo;
doublereal dflag, dtemp; doublereal dflag, dtemp;
/* Assigned format variables */ /* Assigned format variables */
static char *igo_fmt; static char *igo_fmt;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ /* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */ /* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */
/* DY2)**T. */ /* DY2)**T. */
/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ /* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ /* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ /* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
/* H=( ) ( ) ( ) ( ) */ /* H=( ) ( ) ( ) ( ) */
/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ /* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ /* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */
/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ /* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */
/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ /* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */
/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ /* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ /* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ /* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
/* Arguments */
/* ========= */
/* Arguments */ /* DD1 (input/output) DOUBLE PRECISION */
/* ========= */
/* DD1 (input/output) DOUBLE PRECISION */ /* DD2 (input/output) DOUBLE PRECISION */
/* DD2 (input/output) DOUBLE PRECISION */ /* DX1 (input/output) DOUBLE PRECISION */
/* DX1 (input/output) DOUBLE PRECISION */ /* DY1 (input) DOUBLE PRECISION */
/* DY1 (input) DOUBLE PRECISION */ /* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */
/* DPARAM(1)=DFLAG */
/* DPARAM(2)=DH11 */
/* DPARAM(3)=DH21 */
/* DPARAM(4)=DH12 */
/* DPARAM(5)=DH22 */
/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ /* ===================================================================== */
/* DPARAM(1)=DFLAG */
/* DPARAM(2)=DH11 */
/* DPARAM(3)=DH21 */
/* DPARAM(4)=DH12 */
/* DPARAM(5)=DH22 */
/* ===================================================================== */ /* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* .. Local Scalars .. */ /* Parameter adjustments */
/* .. */ --dparam;
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */ /* Function Body */
--dparam; /* .. */
if (!(*dd1 < zero)) {
/* Function Body */ goto L10;
/* .. */ }
if (! (*dd1 < zero)) { /* GO ZERO-H-D-AND-DX1.. */
goto L10; goto L60;
}
/* GO ZERO-H-D-AND-DX1.. */
goto L60;
L10: L10:
/* CASE-DD1-NONNEGATIVE */ /* CASE-DD1-NONNEGATIVE */
dp2 = *dd2 * *dy1; dp2 = *dd2 * *dy1;
if (! (dp2 == zero)) { if (!(dp2 == zero)) {
goto L20; goto L20;
} }
dflag = -two; dflag = -two;
goto L260; goto L260;
/* REGULAR-CASE.. */ /* REGULAR-CASE.. */
L20: L20:
dp1 = *dd1 * *dx1; dp1 = *dd1 * *dx1;
dq2 = dp2 * *dy1; dq2 = dp2 * *dy1;
dq1 = dp1 * *dx1; dq1 = dp1 * *dx1;
if (! (abs(dq1) > abs(dq2))) { if (!(abs(dq1) > abs(dq2))) {
goto L40; goto L40;
} }
dh21 = -(*dy1) / *dx1; dh21 = -(*dy1) / *dx1;
dh12 = dp2 / dp1; dh12 = dp2 / dp1;
du = one - dh12 * dh21; du = one - dh12 * dh21;
if (! (du <= zero)) { if (!(du <= zero)) {
goto L30; goto L30;
} }
/* GO ZERO-H-D-AND-DX1.. */ /* GO ZERO-H-D-AND-DX1.. */
goto L60; goto L60;
L30: L30:
dflag = zero; dflag = zero;
*dd1 /= du; *dd1 /= du;
*dd2 /= du; *dd2 /= du;
*dx1 *= du; *dx1 *= du;
/* GO SCALE-CHECK.. */ /* GO SCALE-CHECK.. */
goto L100; goto L100;
L40: L40:
if (! (dq2 < zero)) { if (!(dq2 < zero)) {
goto L50; goto L50;
} }
/* GO ZERO-H-D-AND-DX1.. */ /* GO ZERO-H-D-AND-DX1.. */
goto L60; goto L60;
L50: L50:
dflag = one; dflag = one;
dh11 = dp1 / dp2; dh11 = dp1 / dp2;
dh22 = *dx1 / *dy1; dh22 = *dx1 / *dy1;
du = one + dh11 * dh22; du = one + dh11 * dh22;
dtemp = *dd2 / du; dtemp = *dd2 / du;
*dd2 = *dd1 / du; *dd2 = *dd1 / du;
*dd1 = dtemp; *dd1 = dtemp;
*dx1 = *dy1 * du; *dx1 = *dy1 * du;
/* GO SCALE-CHECK */ /* GO SCALE-CHECK */
goto L100; goto L100;
/* PROCEDURE..ZERO-H-D-AND-DX1.. */ /* PROCEDURE..ZERO-H-D-AND-DX1.. */
L60: L60:
dflag = -one; dflag = -one;
dh11 = zero; dh11 = zero;
dh12 = zero; dh12 = zero;
dh21 = zero; dh21 = zero;
dh22 = zero; dh22 = zero;
*dd1 = zero; *dd1 = zero;
*dd2 = zero; *dd2 = zero;
*dx1 = zero; *dx1 = zero;
/* RETURN.. */ /* RETURN.. */
goto L220; goto L220;
/* PROCEDURE..FIX-H.. */ /* PROCEDURE..FIX-H.. */
L70: L70:
if (! (dflag >= zero)) { if (!(dflag >= zero)) {
goto L90;
}
if (! (dflag == zero)) {
goto L80;
}
dh11 = one;
dh22 = one;
dflag = -one;
goto L90; goto L90;
}
if (!(dflag == zero)) {
goto L80;
}
dh11 = one;
dh22 = one;
dflag = -one;
goto L90;
L80: L80:
dh21 = -one; dh21 = -one;
dh12 = one; dh12 = one;
dflag = -one; dflag = -one;
L90: L90:
switch (igo) { switch (igo) {
case 0: goto L120; case 0:
case 1: goto L150; goto L120;
case 2: goto L180; case 1:
case 3: goto L210; goto L150;
} case 2:
goto L180;
case 3:
goto L210;
}
/* PROCEDURE..SCALE-CHECK */ /* PROCEDURE..SCALE-CHECK */
L100: L100:
L110: L110:
if (! (*dd1 <= rgamsq)) { if (!(*dd1 <= rgamsq)) {
goto L130; goto L130;
} }
if (*dd1 == zero) { if (*dd1 == zero) {
goto L160; goto L160;
} }
igo = 0; igo = 0;
igo_fmt = fmt_120; igo_fmt = fmt_120;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L120: L120:
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = gam; d__1 = gam;
*dd1 *= d__1 * d__1; *dd1 *= d__1 * d__1;
*dx1 /= gam; *dx1 /= gam;
dh11 /= gam; dh11 /= gam;
dh12 /= gam; dh12 /= gam;
goto L110; goto L110;
L130: L130:
L140: L140:
if (! (*dd1 >= gamsq)) { if (!(*dd1 >= gamsq)) {
goto L160; goto L160;
} }
igo = 1; igo = 1;
igo_fmt = fmt_150; igo_fmt = fmt_150;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L150: L150:
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = gam; d__1 = gam;
*dd1 /= d__1 * d__1; *dd1 /= d__1 * d__1;
*dx1 *= gam; *dx1 *= gam;
dh11 *= gam; dh11 *= gam;
dh12 *= gam; dh12 *= gam;
goto L140; goto L140;
L160: L160:
L170: L170:
if (! (abs(*dd2) <= rgamsq)) { if (!(abs(*dd2) <= rgamsq)) {
goto L190; goto L190;
} }
if (*dd2 == zero) { if (*dd2 == zero) {
goto L220; goto L220;
} }
igo = 2; igo = 2;
igo_fmt = fmt_180; igo_fmt = fmt_180;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L180: L180:
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = gam; d__1 = gam;
*dd2 *= d__1 * d__1; *dd2 *= d__1 * d__1;
dh21 /= gam; dh21 /= gam;
dh22 /= gam; dh22 /= gam;
goto L170; goto L170;
L190: L190:
L200: L200:
if (! (abs(*dd2) >= gamsq)) { if (!(abs(*dd2) >= gamsq)) {
goto L220; goto L220;
} }
igo = 3; igo = 3;
igo_fmt = fmt_210; igo_fmt = fmt_210;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L210: L210:
/* Computing 2nd power */ /* Computing 2nd power */
d__1 = gam; d__1 = gam;
*dd2 /= d__1 * d__1; *dd2 /= d__1 * d__1;
dh21 *= gam; dh21 *= gam;
dh22 *= gam; dh22 *= gam;
goto L200; goto L200;
L220: L220:
if (dflag < 0.) { if (dflag < 0.) {
goto L250; goto L250;
} else if (dflag == 0) { } else if (dflag == 0) {
goto L230; goto L230;
} else { } else {
goto L240; goto L240;
} }
L230: L230:
dparam[3] = dh21; dparam[3] = dh21;
dparam[4] = dh12; dparam[4] = dh12;
goto L260; goto L260;
L240: L240:
dparam[2] = dh11; dparam[2] = dh11;
dparam[5] = dh22; dparam[5] = dh22;
goto L260; goto L260;
L250: L250:
dparam[2] = dh11; dparam[2] = dh11;
dparam[3] = dh21; dparam[3] = dh21;
dparam[4] = dh12; dparam[4] = dh12;
dparam[5] = dh22; dparam[5] = dh22;
L260: L260:
dparam[1] = dflag; dparam[1] = dflag;
return 0; return 0;
} /* drotmg_ */ } /* drotmg_ */

639
blas/f2c/dsbmv.c
View File

@ -1,366 +1,359 @@
/* dsbmv.f -- translated by f2c (version 20100827). /* dsbmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal * /* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy,
doublereal *beta, doublereal *y, integer *incy, ftnlen uplo_len) ftnlen uplo_len) {
{ /* System generated locals */
/* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, j, l, ix, iy, jx, jy, kx, ky, info; integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
doublereal temp1, temp2; doublereal temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kplus1; integer kplus1;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* DSBMV performs the matrix-vector operation */ /* DSBMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n symmetric band matrix, with k super-diagonals. */ /* A is an n by n symmetric band matrix, with k super-diagonals. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the band matrix A is being supplied as */ /* triangular part of the band matrix A is being supplied as */
/* follows: */ /* follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* being supplied. */ /* being supplied. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* being supplied. */ /* being supplied. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* K - INTEGER. */ /* K - INTEGER. */
/* On entry, K specifies the number of super-diagonals of the */ /* On entry, K specifies the number of super-diagonals of the */
/* matrix A. K must satisfy 0 .le. K. */ /* matrix A. K must satisfy 0 .le. K. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - DOUBLE PRECISION. */ /* ALPHA - DOUBLE PRECISION. */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ /* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ /* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
/* by n part of the array A must contain the upper triangular */ /* by n part of the array A must contain the upper triangular */
/* band part of the symmetric matrix, supplied column by */ /* band part of the symmetric matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row */ /* column, with the leading diagonal of the matrix in row */
/* ( k + 1 ) of the array, the first super-diagonal starting at */ /* ( k + 1 ) of the array, the first super-diagonal starting at */
/* position 2 in row k, and so on. The top left k by k triangle */ /* position 2 in row k, and so on. The top left k by k triangle */
/* of the array A is not referenced. */ /* of the array A is not referenced. */
/* The following program segment will transfer the upper */ /* The following program segment will transfer the upper */
/* triangular part of a symmetric band matrix from conventional */ /* triangular part of a symmetric band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = K + 1 - J */ /* M = K + 1 - J */
/* DO 10, I = MAX( 1, J - K ), J */ /* DO 10, I = MAX( 1, J - K ), J */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ /* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
/* by n part of the array A must contain the lower triangular */ /* by n part of the array A must contain the lower triangular */
/* band part of the symmetric matrix, supplied column by */ /* band part of the symmetric matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row 1 of */ /* column, with the leading diagonal of the matrix in row 1 of */
/* the array, the first sub-diagonal starting at position 1 in */ /* the array, the first sub-diagonal starting at position 1 in */
/* row 2, and so on. The bottom right k by k triangle of the */ /* row 2, and so on. The bottom right k by k triangle of the */
/* array A is not referenced. */ /* array A is not referenced. */
/* The following program segment will transfer the lower */ /* The following program segment will transfer the lower */
/* triangular part of a symmetric band matrix from conventional */ /* triangular part of a symmetric band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = 1 - J */ /* M = 1 - J */
/* DO 10, I = J, MIN( N, J + K ) */ /* DO 10, I = J, MIN( N, J + K ) */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* LDA - INTEGER. */ /* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */ /* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */ /* in the calling (sub) program. LDA must be at least */
/* ( k + 1 ). */ /* ( k + 1 ). */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - DOUBLE PRECISION array of DIMENSION at least */ /* X - DOUBLE PRECISION array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the */ /* Before entry, the incremented array X must contain the */
/* vector x. */ /* vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - DOUBLE PRECISION. */ /* BETA - DOUBLE PRECISION. */
/* On entry, BETA specifies the scalar beta. */ /* On entry, BETA specifies the scalar beta. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - DOUBLE PRECISION array of DIMENSION at least */ /* Y - DOUBLE PRECISION array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the */ /* Before entry, the incremented array Y must contain the */
/* vector y. On exit, Y is overwritten by the updated vector y. */ /* vector y. On exit, Y is overwritten by the updated vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Level 2 Blas routine. */
/* 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. */
/* -- 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. */
/* ===================================================================== */ /* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Parameters .. */ /* Test the input parameters. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Test the input parameters. */ /* Parameter adjustments */
a_dim1 = *lda;
/* Parameter adjustments */ a_offset = 1 + a_dim1;
a_dim1 = *lda; a -= a_offset;
a_offset = 1 + a_dim1; --x;
a -= a_offset; --y;
--x;
--y;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("DSBMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array 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 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L50: */
}
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
temp2;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
y[j] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
y[j] += *alpha * temp2;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
y[jy] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("DSBMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of DSBMV . */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array 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 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L50: */
}
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
y[j] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
y[j] += *alpha * temp2;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
y[jy] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of DSBMV . */
} /* dsbmv_ */ } /* dsbmv_ */

550
blas/f2c/dspmv.c
View File

@ -1,316 +1,310 @@
/* dspmv.f -- translated by f2c (version 20100827). /* dspmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha, /* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha, doublereal *ap, doublereal *x, integer *incx,
doublereal *ap, doublereal *x, integer *incx, doublereal *beta, doublereal *beta, doublereal *y, integer *incy, ftnlen uplo_len) {
doublereal *y, integer *incy, ftnlen uplo_len) /* System generated locals */
{ integer i__1, i__2;
/* System generated locals */
integer i__1, i__2;
/* Local variables */ /* Local variables */
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
doublereal temp1, temp2; doublereal temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* DSPMV performs the matrix-vector operation */ /* DSPMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n symmetric matrix, supplied in packed form. */ /* A is an n by n symmetric matrix, supplied in packed form. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the matrix A is supplied in the packed */ /* triangular part of the matrix A is supplied in the packed */
/* array AP as follows: */ /* array AP as follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - DOUBLE PRECISION. */ /* ALPHA - DOUBLE PRECISION. */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* AP - DOUBLE PRECISION array of DIMENSION at least */ /* AP - DOUBLE PRECISION array of DIMENSION at least */
/* ( ( n*( n + 1 ) )/2 ). */ /* ( ( n*( n + 1 ) )/2 ). */
/* Before entry with UPLO = 'U' or 'u', the array AP must */ /* Before entry with UPLO = 'U' or 'u', the array AP must */
/* contain the upper triangular part of the symmetric matrix */ /* contain the upper triangular part of the symmetric matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
/* and a( 2, 2 ) respectively, and so on. */ /* and a( 2, 2 ) respectively, and so on. */
/* Before entry with UPLO = 'L' or 'l', the array AP must */ /* Before entry with UPLO = 'L' or 'l', the array AP must */
/* contain the lower triangular part of the symmetric matrix */ /* contain the lower triangular part of the symmetric matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
/* and a( 3, 1 ) respectively, and so on. */ /* and a( 3, 1 ) respectively, and so on. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - DOUBLE PRECISION array of dimension at least */ /* X - DOUBLE PRECISION array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */ /* Before entry, the incremented array X must contain the n */
/* element vector x. */ /* element vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - DOUBLE PRECISION. */ /* BETA - DOUBLE PRECISION. */
/* On entry, BETA specifies the scalar beta. When BETA is */ /* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */ /* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - DOUBLE PRECISION array of dimension at least */ /* Y - DOUBLE PRECISION array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the n */ /* Before entry, the incremented array Y must contain the n */
/* element vector y. On exit, Y is overwritten by the updated */ /* element vector y. On exit, Y is overwritten by the updated */
/* vector y. */ /* vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
--y; --y;
--x; --x;
--ap; --ap;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("DSPMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (*beta != 1.) {
if (*incy == 1) {
if (*beta == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L50: */
}
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
y[j] += temp1 * ap[kk];
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L90: */
}
y[j] += *alpha * temp2;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
y[jy] += temp1 * ap[kk];
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("DSPMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of DSPMV . */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (*beta != 1.) {
if (*incy == 1) {
if (*beta == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L50: */
}
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.;
y[j] += temp1 * ap[kk];
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L90: */
}
y[j] += *alpha * temp2;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.;
y[jy] += temp1 * ap[kk];
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
return 0;
/* End of DSPMV . */
} /* dspmv_ */ } /* dspmv_ */

750
blas/f2c/dtbmv.c
View File

@ -1,428 +1,420 @@
/* dtbmv.f -- translated by f2c (version 20100827). /* dtbmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n, /* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, doublereal *a, integer *lda,
integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal *x, integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) {
ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) /* System generated locals */
{ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, j, l, ix, jx, kx, info; integer i__, j, l, ix, jx, kx, info;
doublereal temp; doublereal temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kplus1; integer kplus1;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical nounit; logical nounit;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* DTBMV performs one of the matrix-vector operations */ /* DTBMV performs one of the matrix-vector operations */
/* x := A*x, or x := A'*x, */ /* x := A*x, or x := A'*x, */
/* where x is an n element vector and A is an n by n unit, or non-unit, */ /* where x is an n element vector and A is an n by n unit, or non-unit, */
/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ /* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the matrix is an upper or */ /* On entry, UPLO specifies whether the matrix is an upper or */
/* lower triangular matrix as follows: */ /* lower triangular matrix as follows: */
/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ /* UPLO = 'U' or 'u' A is an upper triangular matrix. */
/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ /* UPLO = 'L' or 'l' A is a lower triangular matrix. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* TRANS - CHARACTER*1. */ /* TRANS - CHARACTER*1. */
/* On entry, TRANS specifies the operation to be performed as */ /* On entry, TRANS specifies the operation to be performed as */
/* follows: */ /* follows: */
/* TRANS = 'N' or 'n' x := A*x. */ /* TRANS = 'N' or 'n' x := A*x. */
/* TRANS = 'T' or 't' x := A'*x. */ /* TRANS = 'T' or 't' x := A'*x. */
/* TRANS = 'C' or 'c' x := A'*x. */ /* TRANS = 'C' or 'c' x := A'*x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* DIAG - CHARACTER*1. */ /* DIAG - CHARACTER*1. */
/* On entry, DIAG specifies whether or not A is unit */ /* On entry, DIAG specifies whether or not A is unit */
/* triangular as follows: */ /* triangular as follows: */
/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ /* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
/* DIAG = 'N' or 'n' A is not assumed to be unit */ /* DIAG = 'N' or 'n' A is not assumed to be unit */
/* triangular. */ /* triangular. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* K - INTEGER. */ /* K - INTEGER. */
/* On entry with UPLO = 'U' or 'u', K specifies the number of */ /* On entry with UPLO = 'U' or 'u', K specifies the number of */
/* super-diagonals of the matrix A. */ /* super-diagonals of the matrix A. */
/* On entry with UPLO = 'L' or 'l', K specifies the number of */ /* On entry with UPLO = 'L' or 'l', K specifies the number of */
/* sub-diagonals of the matrix A. */ /* sub-diagonals of the matrix A. */
/* K must satisfy 0 .le. K. */ /* K must satisfy 0 .le. K. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ /* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ /* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
/* by n part of the array A must contain the upper triangular */ /* by n part of the array A must contain the upper triangular */
/* band part of the matrix of coefficients, supplied column by */ /* band part of the matrix of coefficients, supplied column by */
/* column, with the leading diagonal of the matrix in row */ /* column, with the leading diagonal of the matrix in row */
/* ( k + 1 ) of the array, the first super-diagonal starting at */ /* ( k + 1 ) of the array, the first super-diagonal starting at */
/* position 2 in row k, and so on. The top left k by k triangle */ /* position 2 in row k, and so on. The top left k by k triangle */
/* of the array A is not referenced. */ /* of the array A is not referenced. */
/* The following program segment will transfer an upper */ /* The following program segment will transfer an upper */
/* triangular band matrix from conventional full matrix storage */ /* triangular band matrix from conventional full matrix storage */
/* to band storage: */ /* to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = K + 1 - J */ /* M = K + 1 - J */
/* DO 10, I = MAX( 1, J - K ), J */ /* DO 10, I = MAX( 1, J - K ), J */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ /* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
/* by n part of the array A must contain the lower triangular */ /* by n part of the array A must contain the lower triangular */
/* band part of the matrix of coefficients, supplied column by */ /* band part of the matrix of coefficients, supplied column by */
/* column, with the leading diagonal of the matrix in row 1 of */ /* column, with the leading diagonal of the matrix in row 1 of */
/* the array, the first sub-diagonal starting at position 1 in */ /* the array, the first sub-diagonal starting at position 1 in */
/* row 2, and so on. The bottom right k by k triangle of the */ /* row 2, and so on. The bottom right k by k triangle of the */
/* array A is not referenced. */ /* array A is not referenced. */
/* The following program segment will transfer a lower */ /* The following program segment will transfer a lower */
/* triangular band matrix from conventional full matrix storage */ /* triangular band matrix from conventional full matrix storage */
/* to band storage: */ /* to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = 1 - J */ /* M = 1 - J */
/* DO 10, I = J, MIN( N, J + K ) */ /* DO 10, I = J, MIN( N, J + K ) */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Note that when DIAG = 'U' or 'u' the elements of the array A */ /* Note that when DIAG = 'U' or 'u' the elements of the array A */
/* corresponding to the diagonal elements of the matrix are not */ /* corresponding to the diagonal elements of the matrix are not */
/* referenced, but are assumed to be unity. */ /* referenced, but are assumed to be unity. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* LDA - INTEGER. */ /* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */ /* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */ /* in the calling (sub) program. LDA must be at least */
/* ( k + 1 ). */ /* ( k + 1 ). */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - DOUBLE PRECISION array of dimension at least */ /* X - DOUBLE PRECISION array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */ /* Before entry, the incremented array X must contain the n */
/* element vector x. On exit, X is overwritten with the */ /* element vector x. On exit, X is overwritten with the */
/* transformed vector x. */ /* transformed vector x. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
a_dim1 = *lda; a_dim1 = *lda;
a_offset = 1 + a_dim1; a_offset = 1 + a_dim1;
a -= a_offset; a -= a_offset;
--x; --x;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
ftnlen)1)) {
info = 2;
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
"N", (ftnlen)1, (ftnlen)1)) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*k < 0) {
info = 5;
} else if (*lda < *k + 1) {
info = 7;
} else if (*incx == 0) {
info = 9;
}
if (info != 0) {
xerbla_("DTBMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* 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", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[j] != 0.) {
temp = x[j];
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L10: */
}
if (nounit) {
x[j] *= a[kplus1 + 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;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix += *incx;
/* L30: */
}
if (nounit) {
x[jx] *= a[kplus1 + j * a_dim1];
}
}
jx += *incx;
if (j > *k) {
kx += *incx;
}
/* L40: */
}
}
} else {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
if (x[j] != 0.) {
temp = x[j];
l = 1 - j;
/* Computing MIN */
i__1 = *n, i__3 = j + *k;
i__4 = j + 1;
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L50: */
}
if (nounit) {
x[j] *= a[j * a_dim1 + 1];
}
}
/* L60: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
if (x[jx] != 0.) {
temp = x[jx];
ix = kx;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__1 = j + *k;
i__3 = j + 1;
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix -= *incx;
/* L70: */
}
if (nounit) {
x[jx] *= a[j * a_dim1 + 1];
}
}
jx -= *incx;
if (*n - j >= *k) {
kx -= *incx;
}
/* L80: */
}
}
}
} else {
/* Form x := A'*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
temp = x[j];
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
x[j] = temp;
/* L100: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
temp = x[jx];
kx -= *incx;
ix = kx;
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix -= *incx;
/* L110: */
}
x[jx] = temp;
jx -= *incx;
/* L120: */
}
}
} else {
if (*incx == 1) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[j];
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L130: */
}
x[j] = temp;
/* L140: */
}
} else {
jx = kx;
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[jx];
kx += *incx;
ix = kx;
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
/* L150: */
}
x[jx] = temp;
jx += *incx;
/* L160: */
}
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (!lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && !lsame_(trans, "T", (ftnlen)1, (ftnlen)1) &&
!lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
info = 2;
} else if (!lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && !lsame_(diag, "N", (ftnlen)1, (ftnlen)1)) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*k < 0) {
info = 5;
} else if (*lda < *k + 1) {
info = 7;
} else if (*incx == 0) {
info = 9;
}
if (info != 0) {
xerbla_("DTBMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of DTBMV . */ /* Quick return if possible. */
if (*n == 0) {
return 0;
}
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* 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", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[j] != 0.) {
temp = x[j];
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L10: */
}
if (nounit) {
x[j] *= a[kplus1 + 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;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix += *incx;
/* L30: */
}
if (nounit) {
x[jx] *= a[kplus1 + j * a_dim1];
}
}
jx += *incx;
if (j > *k) {
kx += *incx;
}
/* L40: */
}
}
} else {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
if (x[j] != 0.) {
temp = x[j];
l = 1 - j;
/* Computing MIN */
i__1 = *n, i__3 = j + *k;
i__4 = j + 1;
for (i__ = min(i__1, i__3); i__ >= i__4; --i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L50: */
}
if (nounit) {
x[j] *= a[j * a_dim1 + 1];
}
}
/* L60: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
if (x[jx] != 0.) {
temp = x[jx];
ix = kx;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__1 = j + *k;
i__3 = j + 1;
for (i__ = min(i__4, i__1); i__ >= i__3; --i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix -= *incx;
/* L70: */
}
if (nounit) {
x[jx] *= a[j * a_dim1 + 1];
}
}
jx -= *incx;
if (*n - j >= *k) {
kx -= *incx;
}
/* L80: */
}
}
}
} else {
/* Form x := A'*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
temp = x[j];
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
x[j] = temp;
/* L100: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
temp = x[jx];
kx -= *incx;
ix = kx;
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix -= *incx;
/* L110: */
}
x[jx] = temp;
jx -= *incx;
/* L120: */
}
}
} else {
if (*incx == 1) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[j];
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L130: */
}
x[j] = temp;
/* L140: */
}
} else {
jx = kx;
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[jx];
kx += *incx;
ix = kx;
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
/* L150: */
}
x[jx] = temp;
jx += *incx;
/* L160: */
}
}
}
}
return 0;
/* End of DTBMV . */
} /* dtbmv_ */ } /* dtbmv_ */

184
blas/f2c/lsame.c
View File

@ -1,117 +1,109 @@
/* lsame.f -- translated by f2c (version 20100827). /* lsame.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
logical lsame_(char *ca, char *cb, ftnlen ca_len, ftnlen cb_len) logical lsame_(char *ca, char *cb, ftnlen ca_len, ftnlen cb_len) {
{ /* System generated locals */
/* System generated locals */ logical ret_val;
logical ret_val;
/* Local variables */ /* Local variables */
integer inta, intb, zcode; integer inta, intb, zcode;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* -- LAPACK auxiliary routine (version 3.1) -- */ /* .. Scalar Arguments .. */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* .. */
/* November 2006 */
/* .. Scalar Arguments .. */ /* Purpose */
/* .. */ /* ======= */
/* Purpose */ /* LSAME returns .TRUE. if CA is the same letter as CB regardless of */
/* ======= */ /* case. */
/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */ /* Arguments */
/* case. */ /* ========= */
/* Arguments */ /* CA (input) CHARACTER*1 */
/* ========= */
/* CA (input) CHARACTER*1 */ /* CB (input) CHARACTER*1 */
/* CA and CB specify the single characters to be compared. */
/* CB (input) CHARACTER*1 */ /* ===================================================================== */
/* CA and CB specify the single characters to be compared. */
/* ===================================================================== */ /* .. Intrinsic Functions .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */ /* Test if the characters are equal */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* Test if the characters are equal */
ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
if (ret_val) {
return ret_val;
}
/* Now test for equivalence if both characters are alphabetic. */
zcode = 'Z';
/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
/* machines, on which ICHAR returns a value with bit 8 set. */
/* ICHAR('A') on Prime machines returns 193 which is the same as */
/* ICHAR('A') on an EBCDIC machine. */
inta = *(unsigned char *)ca;
intb = *(unsigned char *)cb;
if (zcode == 90 || zcode == 122) {
/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
/* upper case 'Z'. */
if (inta >= 97 && inta <= 122) {
inta += -32;
}
if (intb >= 97 && intb <= 122) {
intb += -32;
}
} else if (zcode == 233 || zcode == 169) {
/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
/* upper case 'Z'. */
if ((inta >= 129 && inta <= 137) || (inta >= 145 && inta <= 153) ||
(inta >= 162 && inta <= 169)) {
inta += 64;
}
if ((intb >= 129 && intb <= 137) || (intb >= 145 && intb <= 153) ||
(intb >= 162 && intb <= 169)) {
intb += 64;
}
} else if (zcode == 218 || zcode == 250) {
/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
/* plus 128 of either lower or upper case 'Z'. */
if (inta >= 225 && inta <= 250) {
inta += -32;
}
if (intb >= 225 && intb <= 250) {
intb += -32;
}
}
ret_val = inta == intb;
/* RETURN */
/* End of LSAME */
ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
if (ret_val) {
return ret_val; return ret_val;
} /* lsame_ */ }
/* Now test for equivalence if both characters are alphabetic. */
zcode = 'Z';
/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
/* machines, on which ICHAR returns a value with bit 8 set. */
/* ICHAR('A') on Prime machines returns 193 which is the same as */
/* ICHAR('A') on an EBCDIC machine. */
inta = *(unsigned char *)ca;
intb = *(unsigned char *)cb;
if (zcode == 90 || zcode == 122) {
/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
/* upper case 'Z'. */
if (inta >= 97 && inta <= 122) {
inta += -32;
}
if (intb >= 97 && intb <= 122) {
intb += -32;
}
} else if (zcode == 233 || zcode == 169) {
/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
/* upper case 'Z'. */
if ((inta >= 129 && inta <= 137) || (inta >= 145 && inta <= 153) || (inta >= 162 && inta <= 169)) {
inta += 64;
}
if ((intb >= 129 && intb <= 137) || (intb >= 145 && intb <= 153) || (intb >= 162 && intb <= 169)) {
intb += 64;
}
} else if (zcode == 218 || zcode == 250) {
/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
/* plus 128 of either lower or upper case 'Z'. */
if (inta >= 225 && inta <= 250) {
inta += -32;
}
if (intb >= 225 && intb <= 250) {
intb += -32;
}
}
ret_val = inta == intb;
/* RETURN */
/* End of LSAME */
return ret_val;
} /* lsame_ */

6
blas/f2c/r_cnjg.c
View File

@ -1,6 +1,6 @@
#include "datatypes.h" #include "datatypes.h"
void r_cnjg(complex *r, complex *z) { void r_cnjg(complex *r, complex *z) {
r->r = z->r; r->r = z->r;
r->i = -(z->i); r->i = -(z->i);
} }

350
blas/f2c/srotm.c
View File

@ -1,216 +1,212 @@
/* srotm.f -- translated by f2c (version 20100827). /* srotm.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy, /* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy, integer *incy, real *sparam) {
integer *incy, real *sparam) /* Initialized data */
{
/* Initialized data */
static real zero = 0.f; static real zero = 0.f;
static real two = 2.f; static real two = 2.f;
/* System generated locals */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
/* Local variables */ /* Local variables */
integer i__; integer i__;
real w, z__; real w, z__;
integer kx, ky; integer kx, ky;
real sh11, sh12, sh21, sh22, sflag; real sh11, sh12, sh21, sh22, sflag;
integer nsteps; integer nsteps;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ /* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
/* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */ /* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */
/* (DX**T) */ /* (DX**T) */
/* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ /* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */ /* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */
/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
/* H=( ) ( ) ( ) ( ) */ /* H=( ) ( ) ( ) ( ) */
/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
/* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */ /* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */
/* Arguments */
/* ========= */
/* Arguments */ /* N (input) INTEGER */
/* ========= */ /* number of elements in input vector(s) */
/* N (input) INTEGER */ /* SX (input/output) REAL array, dimension N */
/* number of elements in input vector(s) */ /* double precision vector with N elements */
/* SX (input/output) REAL array, dimension N */ /* INCX (input) INTEGER */
/* double precision vector with N elements */ /* storage spacing between elements of SX */
/* INCX (input) INTEGER */ /* SY (input/output) REAL array, dimension N */
/* storage spacing between elements of SX */ /* double precision vector with N elements */
/* SY (input/output) REAL array, dimension N */ /* INCY (input) INTEGER */
/* double precision vector with N elements */ /* storage spacing between elements of SY */
/* INCY (input) INTEGER */ /* SPARAM (input/output) REAL array, dimension 5 */
/* storage spacing between elements of SY */ /* SPARAM(1)=SFLAG */
/* SPARAM(2)=SH11 */
/* SPARAM(3)=SH21 */
/* SPARAM(4)=SH12 */
/* SPARAM(5)=SH22 */
/* SPARAM (input/output) REAL array, dimension 5 */ /* ===================================================================== */
/* SPARAM(1)=SFLAG */
/* SPARAM(2)=SH11 */
/* SPARAM(3)=SH21 */
/* SPARAM(4)=SH12 */
/* SPARAM(5)=SH22 */
/* ===================================================================== */ /* .. Local Scalars .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--sparam;
--sy;
--sx;
/* .. Local Scalars .. */ /* Function Body */
/* .. */ /* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--sparam;
--sy;
--sx;
/* Function Body */ sflag = sparam[1];
/* .. */ if (*n <= 0 || sflag + two == zero) {
goto L140;
}
if (!(*incx == *incy && *incx > 0)) {
goto L70;
}
sflag = sparam[1]; nsteps = *n * *incx;
if (*n <= 0 || sflag + two == zero) { if (sflag < 0.f) {
goto L140; goto L50;
} } else if (sflag == 0) {
if (! (*incx == *incy && *incx > 0)) { goto L10;
goto L70; } else {
} goto L30;
}
nsteps = *n * *incx;
if (sflag < 0.f) {
goto L50;
} else if (sflag == 0) {
goto L10;
} else {
goto L30;
}
L10: L10:
sh12 = sparam[4]; sh12 = sparam[4];
sh21 = sparam[3]; sh21 = sparam[3];
i__1 = nsteps; i__1 = nsteps;
i__2 = *incx; i__2 = *incx;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
w = sx[i__]; w = sx[i__];
z__ = sy[i__]; z__ = sy[i__];
sx[i__] = w + z__ * sh12; sx[i__] = w + z__ * sh12;
sy[i__] = w * sh21 + z__; sy[i__] = w * sh21 + z__;
/* L20: */ /* L20: */
} }
goto L140; goto L140;
L30: L30:
sh11 = sparam[2]; sh11 = sparam[2];
sh22 = sparam[5]; sh22 = sparam[5];
i__2 = nsteps; i__2 = nsteps;
i__1 = *incx; i__1 = *incx;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
w = sx[i__]; w = sx[i__];
z__ = sy[i__]; z__ = sy[i__];
sx[i__] = w * sh11 + z__; sx[i__] = w * sh11 + z__;
sy[i__] = -w + sh22 * z__; sy[i__] = -w + sh22 * z__;
/* L40: */ /* L40: */
} }
goto L140; goto L140;
L50: L50:
sh11 = sparam[2]; sh11 = sparam[2];
sh12 = sparam[4]; sh12 = sparam[4];
sh21 = sparam[3]; sh21 = sparam[3];
sh22 = sparam[5]; sh22 = sparam[5];
i__1 = nsteps; i__1 = nsteps;
i__2 = *incx; i__2 = *incx;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
w = sx[i__]; w = sx[i__];
z__ = sy[i__]; z__ = sy[i__];
sx[i__] = w * sh11 + z__ * sh12; sx[i__] = w * sh11 + z__ * sh12;
sy[i__] = w * sh21 + z__ * sh22; sy[i__] = w * sh21 + z__ * sh22;
/* L60: */ /* L60: */
} }
goto L140; goto L140;
L70: L70:
kx = 1; kx = 1;
ky = 1; ky = 1;
if (*incx < 0) { if (*incx < 0) {
kx = (1 - *n) * *incx + 1; kx = (1 - *n) * *incx + 1;
} }
if (*incy < 0) { if (*incy < 0) {
ky = (1 - *n) * *incy + 1; ky = (1 - *n) * *incy + 1;
} }
if (sflag < 0.f) { if (sflag < 0.f) {
goto L120; goto L120;
} else if (sflag == 0) { } else if (sflag == 0) {
goto L80; goto L80;
} else { } else {
goto L100; goto L100;
} }
L80: L80:
sh12 = sparam[4]; sh12 = sparam[4];
sh21 = sparam[3]; sh21 = sparam[3];
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w = sx[kx]; w = sx[kx];
z__ = sy[ky]; z__ = sy[ky];
sx[kx] = w + z__ * sh12; sx[kx] = w + z__ * sh12;
sy[ky] = w * sh21 + z__; sy[ky] = w * sh21 + z__;
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
/* L90: */ /* L90: */
} }
goto L140; goto L140;
L100: L100:
sh11 = sparam[2]; sh11 = sparam[2];
sh22 = sparam[5]; sh22 = sparam[5];
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w = sx[kx]; w = sx[kx];
z__ = sy[ky]; z__ = sy[ky];
sx[kx] = w * sh11 + z__; sx[kx] = w * sh11 + z__;
sy[ky] = -w + sh22 * z__; sy[ky] = -w + sh22 * z__;
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
/* L110: */ /* L110: */
} }
goto L140; goto L140;
L120: L120:
sh11 = sparam[2]; sh11 = sparam[2];
sh12 = sparam[4]; sh12 = sparam[4];
sh21 = sparam[3]; sh21 = sparam[3];
sh22 = sparam[5]; sh22 = sparam[5];
i__2 = *n; i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) { for (i__ = 1; i__ <= i__2; ++i__) {
w = sx[kx]; w = sx[kx];
z__ = sy[ky]; z__ = sy[ky];
sx[kx] = w * sh11 + z__ * sh12; sx[kx] = w * sh11 + z__ * sh12;
sy[ky] = w * sh21 + z__ * sh22; sy[ky] = w * sh21 + z__ * sh22;
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
/* L130: */ /* L130: */
} }
L140: L140:
return 0; return 0;
} /* srotm_ */ } /* srotm_ */

460
blas/f2c/srotmg.c
View File

@ -1,295 +1,293 @@
/* srotmg.f -- translated by f2c (version 20100827). /* srotmg.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real /* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real *sparam) {
*sparam) /* Initialized data */
{
/* Initialized data */
static real zero = 0.f; static real zero = 0.f;
static real one = 1.f; static real one = 1.f;
static real two = 2.f; static real two = 2.f;
static real gam = 4096.f; static real gam = 4096.f;
static real gamsq = 16777200.f; static real gamsq = 16777200.f;
static real rgamsq = 5.96046e-8f; static real rgamsq = 5.96046e-8f;
/* Format strings */ /* Format strings */
static char fmt_120[] = ""; static char fmt_120[] = "";
static char fmt_150[] = ""; static char fmt_150[] = "";
static char fmt_180[] = ""; static char fmt_180[] = "";
static char fmt_210[] = ""; static char fmt_210[] = "";
/* System generated locals */ /* System generated locals */
real r__1; real r__1;
/* Local variables */ /* Local variables */
real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22; real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22;
integer igo; integer igo;
real sflag, stemp; real sflag, stemp;
/* Assigned format variables */ /* Assigned format variables */
static char *igo_fmt; static char *igo_fmt;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ /* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
/* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */ /* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */
/* SY2)**T. */ /* SY2)**T. */
/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
/* H=( ) ( ) ( ) ( ) */ /* H=( ) ( ) ( ) ( ) */
/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
/* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */ /* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */
/* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */ /* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */
/* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */ /* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */
/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ /* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ /* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
/* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ /* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
/* Arguments */
/* ========= */
/* Arguments */ /* SD1 (input/output) REAL */
/* ========= */
/* SD2 (input/output) REAL */
/* SD1 (input/output) REAL */ /* SX1 (input/output) REAL */
/* SD2 (input/output) REAL */ /* SY1 (input) REAL */
/* SX1 (input/output) REAL */ /* SPARAM (input/output) REAL array, dimension 5 */
/* SPARAM(1)=SFLAG */
/* SPARAM(2)=SH11 */
/* SPARAM(3)=SH21 */
/* SPARAM(4)=SH12 */
/* SPARAM(5)=SH22 */
/* SY1 (input) REAL */ /* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* SPARAM (input/output) REAL array, dimension 5 */ /* Parameter adjustments */
/* SPARAM(1)=SFLAG */ --sparam;
/* SPARAM(2)=SH11 */
/* SPARAM(3)=SH21 */
/* SPARAM(4)=SH12 */
/* SPARAM(5)=SH22 */
/* ===================================================================== */ /* Function Body */
/* .. */
/* .. Local Scalars .. */ if (!(*sd1 < zero)) {
/* .. */ goto L10;
/* .. Intrinsic Functions .. */ }
/* .. */ /* GO ZERO-H-D-AND-SX1.. */
/* .. Data statements .. */ goto L60;
/* Parameter adjustments */
--sparam;
/* Function Body */
/* .. */
if (! (*sd1 < zero)) {
goto L10;
}
/* GO ZERO-H-D-AND-SX1.. */
goto L60;
L10: L10:
/* CASE-SD1-NONNEGATIVE */ /* CASE-SD1-NONNEGATIVE */
sp2 = *sd2 * *sy1; sp2 = *sd2 * *sy1;
if (! (sp2 == zero)) { if (!(sp2 == zero)) {
goto L20; goto L20;
} }
sflag = -two; sflag = -two;
goto L260; goto L260;
/* REGULAR-CASE.. */ /* REGULAR-CASE.. */
L20: L20:
sp1 = *sd1 * *sx1; sp1 = *sd1 * *sx1;
sq2 = sp2 * *sy1; sq2 = sp2 * *sy1;
sq1 = sp1 * *sx1; sq1 = sp1 * *sx1;
if (! (dabs(sq1) > dabs(sq2))) { if (!(dabs(sq1) > dabs(sq2))) {
goto L40; goto L40;
} }
sh21 = -(*sy1) / *sx1; sh21 = -(*sy1) / *sx1;
sh12 = sp2 / sp1; sh12 = sp2 / sp1;
su = one - sh12 * sh21; su = one - sh12 * sh21;
if (! (su <= zero)) { if (!(su <= zero)) {
goto L30; goto L30;
} }
/* GO ZERO-H-D-AND-SX1.. */ /* GO ZERO-H-D-AND-SX1.. */
goto L60; goto L60;
L30: L30:
sflag = zero; sflag = zero;
*sd1 /= su; *sd1 /= su;
*sd2 /= su; *sd2 /= su;
*sx1 *= su; *sx1 *= su;
/* GO SCALE-CHECK.. */ /* GO SCALE-CHECK.. */
goto L100; goto L100;
L40: L40:
if (! (sq2 < zero)) { if (!(sq2 < zero)) {
goto L50; goto L50;
} }
/* GO ZERO-H-D-AND-SX1.. */ /* GO ZERO-H-D-AND-SX1.. */
goto L60; goto L60;
L50: L50:
sflag = one; sflag = one;
sh11 = sp1 / sp2; sh11 = sp1 / sp2;
sh22 = *sx1 / *sy1; sh22 = *sx1 / *sy1;
su = one + sh11 * sh22; su = one + sh11 * sh22;
stemp = *sd2 / su; stemp = *sd2 / su;
*sd2 = *sd1 / su; *sd2 = *sd1 / su;
*sd1 = stemp; *sd1 = stemp;
*sx1 = *sy1 * su; *sx1 = *sy1 * su;
/* GO SCALE-CHECK */ /* GO SCALE-CHECK */
goto L100; goto L100;
/* PROCEDURE..ZERO-H-D-AND-SX1.. */ /* PROCEDURE..ZERO-H-D-AND-SX1.. */
L60: L60:
sflag = -one; sflag = -one;
sh11 = zero; sh11 = zero;
sh12 = zero; sh12 = zero;
sh21 = zero; sh21 = zero;
sh22 = zero; sh22 = zero;
*sd1 = zero; *sd1 = zero;
*sd2 = zero; *sd2 = zero;
*sx1 = zero; *sx1 = zero;
/* RETURN.. */ /* RETURN.. */
goto L220; goto L220;
/* PROCEDURE..FIX-H.. */ /* PROCEDURE..FIX-H.. */
L70: L70:
if (! (sflag >= zero)) { if (!(sflag >= zero)) {
goto L90;
}
if (! (sflag == zero)) {
goto L80;
}
sh11 = one;
sh22 = one;
sflag = -one;
goto L90; goto L90;
}
if (!(sflag == zero)) {
goto L80;
}
sh11 = one;
sh22 = one;
sflag = -one;
goto L90;
L80: L80:
sh21 = -one; sh21 = -one;
sh12 = one; sh12 = one;
sflag = -one; sflag = -one;
L90: L90:
switch (igo) { switch (igo) {
case 0: goto L120; case 0:
case 1: goto L150; goto L120;
case 2: goto L180; case 1:
case 3: goto L210; goto L150;
} case 2:
goto L180;
case 3:
goto L210;
}
/* PROCEDURE..SCALE-CHECK */ /* PROCEDURE..SCALE-CHECK */
L100: L100:
L110: L110:
if (! (*sd1 <= rgamsq)) { if (!(*sd1 <= rgamsq)) {
goto L130; goto L130;
} }
if (*sd1 == zero) { if (*sd1 == zero) {
goto L160; goto L160;
} }
igo = 0; igo = 0;
igo_fmt = fmt_120; igo_fmt = fmt_120;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L120: L120:
/* Computing 2nd power */ /* Computing 2nd power */
r__1 = gam; r__1 = gam;
*sd1 *= r__1 * r__1; *sd1 *= r__1 * r__1;
*sx1 /= gam; *sx1 /= gam;
sh11 /= gam; sh11 /= gam;
sh12 /= gam; sh12 /= gam;
goto L110; goto L110;
L130: L130:
L140: L140:
if (! (*sd1 >= gamsq)) { if (!(*sd1 >= gamsq)) {
goto L160; goto L160;
} }
igo = 1; igo = 1;
igo_fmt = fmt_150; igo_fmt = fmt_150;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L150: L150:
/* Computing 2nd power */ /* Computing 2nd power */
r__1 = gam; r__1 = gam;
*sd1 /= r__1 * r__1; *sd1 /= r__1 * r__1;
*sx1 *= gam; *sx1 *= gam;
sh11 *= gam; sh11 *= gam;
sh12 *= gam; sh12 *= gam;
goto L140; goto L140;
L160: L160:
L170: L170:
if (! (dabs(*sd2) <= rgamsq)) { if (!(dabs(*sd2) <= rgamsq)) {
goto L190; goto L190;
} }
if (*sd2 == zero) { if (*sd2 == zero) {
goto L220; goto L220;
} }
igo = 2; igo = 2;
igo_fmt = fmt_180; igo_fmt = fmt_180;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L180: L180:
/* Computing 2nd power */ /* Computing 2nd power */
r__1 = gam; r__1 = gam;
*sd2 *= r__1 * r__1; *sd2 *= r__1 * r__1;
sh21 /= gam; sh21 /= gam;
sh22 /= gam; sh22 /= gam;
goto L170; goto L170;
L190: L190:
L200: L200:
if (! (dabs(*sd2) >= gamsq)) { if (!(dabs(*sd2) >= gamsq)) {
goto L220; goto L220;
} }
igo = 3; igo = 3;
igo_fmt = fmt_210; igo_fmt = fmt_210;
/* FIX-H.. */ /* FIX-H.. */
goto L70; goto L70;
L210: L210:
/* Computing 2nd power */ /* Computing 2nd power */
r__1 = gam; r__1 = gam;
*sd2 /= r__1 * r__1; *sd2 /= r__1 * r__1;
sh21 *= gam; sh21 *= gam;
sh22 *= gam; sh22 *= gam;
goto L200; goto L200;
L220: L220:
if (sflag < 0.f) { if (sflag < 0.f) {
goto L250; goto L250;
} else if (sflag == 0) { } else if (sflag == 0) {
goto L230; goto L230;
} else { } else {
goto L240; goto L240;
} }
L230: L230:
sparam[3] = sh21; sparam[3] = sh21;
sparam[4] = sh12; sparam[4] = sh12;
goto L260; goto L260;
L240: L240:
sparam[2] = sh11; sparam[2] = sh11;
sparam[5] = sh22; sparam[5] = sh22;
goto L260; goto L260;
L250: L250:
sparam[2] = sh11; sparam[2] = sh11;
sparam[3] = sh21; sparam[3] = sh21;
sparam[4] = sh12; sparam[4] = sh12;
sparam[5] = sh22; sparam[5] = sh22;
L260: L260:
sparam[1] = sflag; sparam[1] = sflag;
return 0; return 0;
} /* srotmg_ */ } /* srotmg_ */

641
blas/f2c/ssbmv.c
View File

@ -1,368 +1,361 @@
/* ssbmv.f -- translated by f2c (version 20100827). /* ssbmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha, /* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha, real *a, integer *lda, real *x,
real *a, integer *lda, real *x, integer *incx, real *beta, real *y, integer *incx, real *beta, real *y, integer *incy, ftnlen uplo_len) {
integer *incy, ftnlen uplo_len) /* System generated locals */
{ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, j, l, ix, iy, jx, jy, kx, ky, info; integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
real temp1, temp2; real temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kplus1; integer kplus1;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* SSBMV performs the matrix-vector operation */ /* SSBMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n symmetric band matrix, with k super-diagonals. */ /* A is an n by n symmetric band matrix, with k super-diagonals. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the band matrix A is being supplied as */ /* triangular part of the band matrix A is being supplied as */
/* follows: */ /* follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* being supplied. */ /* being supplied. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* being supplied. */ /* being supplied. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* K - INTEGER. */ /* K - INTEGER. */
/* On entry, K specifies the number of super-diagonals of the */ /* On entry, K specifies the number of super-diagonals of the */
/* matrix A. K must satisfy 0 .le. K. */ /* matrix A. K must satisfy 0 .le. K. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - REAL . */ /* ALPHA - REAL . */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* A - REAL array of DIMENSION ( LDA, n ). */ /* A - REAL array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ /* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
/* by n part of the array A must contain the upper triangular */ /* by n part of the array A must contain the upper triangular */
/* band part of the symmetric matrix, supplied column by */ /* band part of the symmetric matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row */ /* column, with the leading diagonal of the matrix in row */
/* ( k + 1 ) of the array, the first super-diagonal starting at */ /* ( k + 1 ) of the array, the first super-diagonal starting at */
/* position 2 in row k, and so on. The top left k by k triangle */ /* position 2 in row k, and so on. The top left k by k triangle */
/* of the array A is not referenced. */ /* of the array A is not referenced. */
/* The following program segment will transfer the upper */ /* The following program segment will transfer the upper */
/* triangular part of a symmetric band matrix from conventional */ /* triangular part of a symmetric band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = K + 1 - J */ /* M = K + 1 - J */
/* DO 10, I = MAX( 1, J - K ), J */ /* DO 10, I = MAX( 1, J - K ), J */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ /* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
/* by n part of the array A must contain the lower triangular */ /* by n part of the array A must contain the lower triangular */
/* band part of the symmetric matrix, supplied column by */ /* band part of the symmetric matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row 1 of */ /* column, with the leading diagonal of the matrix in row 1 of */
/* the array, the first sub-diagonal starting at position 1 in */ /* the array, the first sub-diagonal starting at position 1 in */
/* row 2, and so on. The bottom right k by k triangle of the */ /* row 2, and so on. The bottom right k by k triangle of the */
/* array A is not referenced. */ /* array A is not referenced. */
/* The following program segment will transfer the lower */ /* The following program segment will transfer the lower */
/* triangular part of a symmetric band matrix from conventional */ /* triangular part of a symmetric band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = 1 - J */ /* M = 1 - J */
/* DO 10, I = J, MIN( N, J + K ) */ /* DO 10, I = J, MIN( N, J + K ) */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* LDA - INTEGER. */ /* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */ /* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */ /* in the calling (sub) program. LDA must be at least */
/* ( k + 1 ). */ /* ( k + 1 ). */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - REAL array of DIMENSION at least */ /* X - REAL array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the */ /* Before entry, the incremented array X must contain the */
/* vector x. */ /* vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - REAL . */ /* BETA - REAL . */
/* On entry, BETA specifies the scalar beta. */ /* On entry, BETA specifies the scalar beta. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - REAL array of DIMENSION at least */ /* Y - REAL array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the */ /* Before entry, the incremented array Y must contain the */
/* vector y. On exit, Y is overwritten by the updated vector y. */ /* vector y. On exit, Y is overwritten by the updated vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
a_dim1 = *lda; a_dim1 = *lda;
a_offset = 1 + a_dim1; a_offset = 1 + a_dim1;
a -= a_offset; a -= a_offset;
--x; --x;
--y; --y;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("SSBMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (*beta != 1.f) {
if (*incy == 1) {
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.f) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L50: */
}
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
temp2;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
y[j] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
y[j] += *alpha * temp2;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
y[jy] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("SSBMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of SSBMV . */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (*beta != 1.f) {
if (*incy == 1) {
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.f) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L50: */
}
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
y[j] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
y[j] += *alpha * temp2;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
y[jy] += temp1 * a[j * a_dim1 + 1];
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of SSBMV . */
} /* ssbmv_ */ } /* ssbmv_ */

550
blas/f2c/sspmv.c
View File

@ -1,316 +1,310 @@
/* sspmv.f -- translated by f2c (version 20100827). /* sspmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap, /* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap, real *x, integer *incx, real *beta, real *y,
real *x, integer *incx, real *beta, real *y, integer *incy, ftnlen integer *incy, ftnlen uplo_len) {
uplo_len) /* System generated locals */
{ integer i__1, i__2;
/* System generated locals */
integer i__1, i__2;
/* Local variables */ /* Local variables */
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
real temp1, temp2; real temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* SSPMV performs the matrix-vector operation */ /* SSPMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n symmetric matrix, supplied in packed form. */ /* A is an n by n symmetric matrix, supplied in packed form. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the matrix A is supplied in the packed */ /* triangular part of the matrix A is supplied in the packed */
/* array AP as follows: */ /* array AP as follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - REAL . */ /* ALPHA - REAL . */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* AP - REAL array of DIMENSION at least */ /* AP - REAL array of DIMENSION at least */
/* ( ( n*( n + 1 ) )/2 ). */ /* ( ( n*( n + 1 ) )/2 ). */
/* Before entry with UPLO = 'U' or 'u', the array AP must */ /* Before entry with UPLO = 'U' or 'u', the array AP must */
/* contain the upper triangular part of the symmetric matrix */ /* contain the upper triangular part of the symmetric matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
/* and a( 2, 2 ) respectively, and so on. */ /* and a( 2, 2 ) respectively, and so on. */
/* Before entry with UPLO = 'L' or 'l', the array AP must */ /* Before entry with UPLO = 'L' or 'l', the array AP must */
/* contain the lower triangular part of the symmetric matrix */ /* contain the lower triangular part of the symmetric matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
/* and a( 3, 1 ) respectively, and so on. */ /* and a( 3, 1 ) respectively, and so on. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - REAL array of dimension at least */ /* X - REAL array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */ /* Before entry, the incremented array X must contain the n */
/* element vector x. */ /* element vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - REAL . */ /* BETA - REAL . */
/* On entry, BETA specifies the scalar beta. When BETA is */ /* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */ /* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - REAL array of dimension at least */ /* Y - REAL array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the n */ /* Before entry, the incremented array Y must contain the n */
/* element vector y. On exit, Y is overwritten by the updated */ /* element vector y. On exit, Y is overwritten by the updated */
/* vector y. */ /* vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
--y; --y;
--x; --x;
--ap; --ap;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("SSPMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (*beta != 1.f) {
if (*incy == 1) {
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.f) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L50: */
}
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
y[j] += temp1 * ap[kk];
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L90: */
}
y[j] += *alpha * temp2;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
y[jy] += temp1 * ap[kk];
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("SSPMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of SSPMV . */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (*beta != 1.f) {
if (*incy == 1) {
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.f) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L50: */
}
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
ix += *incx;
iy += *incy;
/* L70: */
}
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[j];
temp2 = 0.f;
y[j] += temp1 * ap[kk];
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__];
++k;
/* L90: */
}
y[j] += *alpha * temp2;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp1 = *alpha * x[jx];
temp2 = 0.f;
y[jy] += temp1 * ap[kk];
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix];
/* L110: */
}
y[jy] += *alpha * temp2;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
return 0;
/* End of SSPMV . */
} /* sspmv_ */ } /* sspmv_ */

750
blas/f2c/stbmv.c
View File

@ -1,428 +1,420 @@
/* stbmv.f -- translated by f2c (version 20100827). /* stbmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n, /* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, real *a, integer *lda, real *x,
integer *k, real *a, integer *lda, real *x, integer *incx, ftnlen integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) {
uplo_len, ftnlen trans_len, ftnlen diag_len) /* System generated locals */
{ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */ /* Local variables */
integer i__, j, l, ix, jx, kx, info; integer i__, j, l, ix, jx, kx, info;
real temp; real temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kplus1; integer kplus1;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical nounit; logical nounit;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* STBMV performs one of the matrix-vector operations */ /* STBMV performs one of the matrix-vector operations */
/* x := A*x, or x := A'*x, */ /* x := A*x, or x := A'*x, */
/* where x is an n element vector and A is an n by n unit, or non-unit, */ /* where x is an n element vector and A is an n by n unit, or non-unit, */
/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ /* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the matrix is an upper or */ /* On entry, UPLO specifies whether the matrix is an upper or */
/* lower triangular matrix as follows: */ /* lower triangular matrix as follows: */
/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ /* UPLO = 'U' or 'u' A is an upper triangular matrix. */
/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ /* UPLO = 'L' or 'l' A is a lower triangular matrix. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* TRANS - CHARACTER*1. */ /* TRANS - CHARACTER*1. */
/* On entry, TRANS specifies the operation to be performed as */ /* On entry, TRANS specifies the operation to be performed as */
/* follows: */ /* follows: */
/* TRANS = 'N' or 'n' x := A*x. */ /* TRANS = 'N' or 'n' x := A*x. */
/* TRANS = 'T' or 't' x := A'*x. */ /* TRANS = 'T' or 't' x := A'*x. */
/* TRANS = 'C' or 'c' x := A'*x. */ /* TRANS = 'C' or 'c' x := A'*x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* DIAG - CHARACTER*1. */ /* DIAG - CHARACTER*1. */
/* On entry, DIAG specifies whether or not A is unit */ /* On entry, DIAG specifies whether or not A is unit */
/* triangular as follows: */ /* triangular as follows: */
/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ /* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
/* DIAG = 'N' or 'n' A is not assumed to be unit */ /* DIAG = 'N' or 'n' A is not assumed to be unit */
/* triangular. */ /* triangular. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* K - INTEGER. */ /* K - INTEGER. */
/* On entry with UPLO = 'U' or 'u', K specifies the number of */ /* On entry with UPLO = 'U' or 'u', K specifies the number of */
/* super-diagonals of the matrix A. */ /* super-diagonals of the matrix A. */
/* On entry with UPLO = 'L' or 'l', K specifies the number of */ /* On entry with UPLO = 'L' or 'l', K specifies the number of */
/* sub-diagonals of the matrix A. */ /* sub-diagonals of the matrix A. */
/* K must satisfy 0 .le. K. */ /* K must satisfy 0 .le. K. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* A - REAL array of DIMENSION ( LDA, n ). */ /* A - REAL array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ /* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
/* by n part of the array A must contain the upper triangular */ /* by n part of the array A must contain the upper triangular */
/* band part of the matrix of coefficients, supplied column by */ /* band part of the matrix of coefficients, supplied column by */
/* column, with the leading diagonal of the matrix in row */ /* column, with the leading diagonal of the matrix in row */
/* ( k + 1 ) of the array, the first super-diagonal starting at */ /* ( k + 1 ) of the array, the first super-diagonal starting at */
/* position 2 in row k, and so on. The top left k by k triangle */ /* position 2 in row k, and so on. The top left k by k triangle */
/* of the array A is not referenced. */ /* of the array A is not referenced. */
/* The following program segment will transfer an upper */ /* The following program segment will transfer an upper */
/* triangular band matrix from conventional full matrix storage */ /* triangular band matrix from conventional full matrix storage */
/* to band storage: */ /* to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = K + 1 - J */ /* M = K + 1 - J */
/* DO 10, I = MAX( 1, J - K ), J */ /* DO 10, I = MAX( 1, J - K ), J */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ /* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
/* by n part of the array A must contain the lower triangular */ /* by n part of the array A must contain the lower triangular */
/* band part of the matrix of coefficients, supplied column by */ /* band part of the matrix of coefficients, supplied column by */
/* column, with the leading diagonal of the matrix in row 1 of */ /* column, with the leading diagonal of the matrix in row 1 of */
/* the array, the first sub-diagonal starting at position 1 in */ /* the array, the first sub-diagonal starting at position 1 in */
/* row 2, and so on. The bottom right k by k triangle of the */ /* row 2, and so on. The bottom right k by k triangle of the */
/* array A is not referenced. */ /* array A is not referenced. */
/* The following program segment will transfer a lower */ /* The following program segment will transfer a lower */
/* triangular band matrix from conventional full matrix storage */ /* triangular band matrix from conventional full matrix storage */
/* to band storage: */ /* to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = 1 - J */ /* M = 1 - J */
/* DO 10, I = J, MIN( N, J + K ) */ /* DO 10, I = J, MIN( N, J + K ) */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Note that when DIAG = 'U' or 'u' the elements of the array A */ /* Note that when DIAG = 'U' or 'u' the elements of the array A */
/* corresponding to the diagonal elements of the matrix are not */ /* corresponding to the diagonal elements of the matrix are not */
/* referenced, but are assumed to be unity. */ /* referenced, but are assumed to be unity. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* LDA - INTEGER. */ /* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */ /* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */ /* in the calling (sub) program. LDA must be at least */
/* ( k + 1 ). */ /* ( k + 1 ). */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - REAL array of dimension at least */ /* X - REAL array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */ /* Before entry, the incremented array X must contain the n */
/* element vector x. On exit, X is overwritten with the */ /* element vector x. On exit, X is overwritten with the */
/* transformed vector x. */ /* transformed vector x. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
a_dim1 = *lda; a_dim1 = *lda;
a_offset = 1 + a_dim1; a_offset = 1 + a_dim1;
a -= a_offset; a -= a_offset;
--x; --x;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
ftnlen)1)) {
info = 2;
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
"N", (ftnlen)1, (ftnlen)1)) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*k < 0) {
info = 5;
} else if (*lda < *k + 1) {
info = 7;
} else if (*incx == 0) {
info = 9;
}
if (info != 0) {
xerbla_("STBMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* 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", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[j] != 0.f) {
temp = x[j];
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L10: */
}
if (nounit) {
x[j] *= a[kplus1 + j * a_dim1];
}
}
/* L20: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[jx] != 0.f) {
temp = x[jx];
ix = kx;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix += *incx;
/* L30: */
}
if (nounit) {
x[jx] *= a[kplus1 + j * a_dim1];
}
}
jx += *incx;
if (j > *k) {
kx += *incx;
}
/* L40: */
}
}
} else {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
if (x[j] != 0.f) {
temp = x[j];
l = 1 - j;
/* Computing MIN */
i__1 = *n, i__3 = j + *k;
i__4 = j + 1;
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L50: */
}
if (nounit) {
x[j] *= a[j * a_dim1 + 1];
}
}
/* L60: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
if (x[jx] != 0.f) {
temp = x[jx];
ix = kx;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__1 = j + *k;
i__3 = j + 1;
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix -= *incx;
/* L70: */
}
if (nounit) {
x[jx] *= a[j * a_dim1 + 1];
}
}
jx -= *incx;
if (*n - j >= *k) {
kx -= *incx;
}
/* L80: */
}
}
}
} else {
/* Form x := A'*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
temp = x[j];
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
x[j] = temp;
/* L100: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
temp = x[jx];
kx -= *incx;
ix = kx;
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix -= *incx;
/* L110: */
}
x[jx] = temp;
jx -= *incx;
/* L120: */
}
}
} else {
if (*incx == 1) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[j];
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L130: */
}
x[j] = temp;
/* L140: */
}
} else {
jx = kx;
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[jx];
kx += *incx;
ix = kx;
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
/* L150: */
}
x[jx] = temp;
jx += *incx;
/* L160: */
}
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (!lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && !lsame_(trans, "T", (ftnlen)1, (ftnlen)1) &&
!lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
info = 2;
} else if (!lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && !lsame_(diag, "N", (ftnlen)1, (ftnlen)1)) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*k < 0) {
info = 5;
} else if (*lda < *k + 1) {
info = 7;
} else if (*incx == 0) {
info = 9;
}
if (info != 0) {
xerbla_("STBMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of STBMV . */ /* Quick return if possible. */
if (*n == 0) {
return 0;
}
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* 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", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[j] != 0.f) {
temp = x[j];
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L10: */
}
if (nounit) {
x[j] *= a[kplus1 + j * a_dim1];
}
}
/* L20: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[jx] != 0.f) {
temp = x[jx];
ix = kx;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix += *incx;
/* L30: */
}
if (nounit) {
x[jx] *= a[kplus1 + j * a_dim1];
}
}
jx += *incx;
if (j > *k) {
kx += *incx;
}
/* L40: */
}
}
} else {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
if (x[j] != 0.f) {
temp = x[j];
l = 1 - j;
/* Computing MIN */
i__1 = *n, i__3 = j + *k;
i__4 = j + 1;
for (i__ = min(i__1, i__3); i__ >= i__4; --i__) {
x[i__] += temp * a[l + i__ + j * a_dim1];
/* L50: */
}
if (nounit) {
x[j] *= a[j * a_dim1 + 1];
}
}
/* L60: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
if (x[jx] != 0.f) {
temp = x[jx];
ix = kx;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__1 = j + *k;
i__3 = j + 1;
for (i__ = min(i__4, i__1); i__ >= i__3; --i__) {
x[ix] += temp * a[l + i__ + j * a_dim1];
ix -= *incx;
/* L70: */
}
if (nounit) {
x[jx] *= a[j * a_dim1 + 1];
}
}
jx -= *incx;
if (*n - j >= *k) {
kx -= *incx;
}
/* L80: */
}
}
}
} else {
/* Form x := A'*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1;
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
temp = x[j];
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */
}
x[j] = temp;
/* L100: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
temp = x[jx];
kx -= *incx;
ix = kx;
l = kplus1 - j;
if (nounit) {
temp *= a[kplus1 + j * a_dim1];
}
/* Computing MAX */
i__4 = 1, i__1 = j - *k;
i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix -= *incx;
/* L110: */
}
x[jx] = temp;
jx -= *incx;
/* L120: */
}
}
} else {
if (*incx == 1) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[j];
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[i__];
/* L130: */
}
x[j] = temp;
/* L140: */
}
} else {
jx = kx;
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
temp = x[jx];
kx += *incx;
ix = kx;
l = 1 - j;
if (nounit) {
temp *= a[j * a_dim1 + 1];
}
/* Computing MIN */
i__1 = *n, i__2 = j + *k;
i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx;
/* L150: */
}
x[jx] = temp;
jx += *incx;
/* L160: */
}
}
}
}
return 0;
/* End of STBMV . */
} /* stbmv_ */ } /* stbmv_ */

855
blas/f2c/zhbmv.c
View File

@ -1,488 +1,457 @@
/* zhbmv.f -- translated by f2c (version 20100827). /* zhbmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int zhbmv_(char *uplo, integer *n, integer *k, doublecomplex /* Subroutine */ int zhbmv_(char *uplo, integer *n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda,
*alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer * doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *incy,
incx, doublecomplex *beta, doublecomplex *y, integer *incy, ftnlen ftnlen uplo_len) {
uplo_len) /* System generated locals */
{ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* System generated locals */ doublereal d__1;
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1, z__2, z__3, z__4;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */ /* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */ /* Local variables */
integer i__, j, l, ix, iy, jx, jy, kx, ky, info; integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
doublecomplex temp1, temp2; doublecomplex temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kplus1; integer kplus1;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* ZHBMV performs the matrix-vector operation */ /* ZHBMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n hermitian band matrix, with k super-diagonals. */ /* A is an n by n hermitian band matrix, with k super-diagonals. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the band matrix A is being supplied as */ /* triangular part of the band matrix A is being supplied as */
/* follows: */ /* follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* being supplied. */ /* being supplied. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* being supplied. */ /* being supplied. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* K - INTEGER. */ /* K - INTEGER. */
/* On entry, K specifies the number of super-diagonals of the */ /* On entry, K specifies the number of super-diagonals of the */
/* matrix A. K must satisfy 0 .le. K. */ /* matrix A. K must satisfy 0 .le. K. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - COMPLEX*16 . */ /* ALPHA - COMPLEX*16 . */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ /* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ /* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
/* by n part of the array A must contain the upper triangular */ /* by n part of the array A must contain the upper triangular */
/* band part of the hermitian matrix, supplied column by */ /* band part of the hermitian matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row */ /* column, with the leading diagonal of the matrix in row */
/* ( k + 1 ) of the array, the first super-diagonal starting at */ /* ( k + 1 ) of the array, the first super-diagonal starting at */
/* position 2 in row k, and so on. The top left k by k triangle */ /* position 2 in row k, and so on. The top left k by k triangle */
/* of the array A is not referenced. */ /* of the array A is not referenced. */
/* The following program segment will transfer the upper */ /* The following program segment will transfer the upper */
/* triangular part of a hermitian band matrix from conventional */ /* triangular part of a hermitian band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = K + 1 - J */ /* M = K + 1 - J */
/* DO 10, I = MAX( 1, J - K ), J */ /* DO 10, I = MAX( 1, J - K ), J */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ /* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
/* by n part of the array A must contain the lower triangular */ /* by n part of the array A must contain the lower triangular */
/* band part of the hermitian matrix, supplied column by */ /* band part of the hermitian matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row 1 of */ /* column, with the leading diagonal of the matrix in row 1 of */
/* the array, the first sub-diagonal starting at position 1 in */ /* the array, the first sub-diagonal starting at position 1 in */
/* row 2, and so on. The bottom right k by k triangle of the */ /* row 2, and so on. The bottom right k by k triangle of the */
/* array A is not referenced. */ /* array A is not referenced. */
/* The following program segment will transfer the lower */ /* The following program segment will transfer the lower */
/* triangular part of a hermitian band matrix from conventional */ /* triangular part of a hermitian band matrix from conventional */
/* full matrix storage to band storage: */ /* full matrix storage to band storage: */
/* DO 20, J = 1, N */ /* DO 20, J = 1, N */
/* M = 1 - J */ /* M = 1 - J */
/* DO 10, I = J, MIN( N, J + K ) */ /* DO 10, I = J, MIN( N, J + K ) */
/* A( M + I, J ) = matrix( I, J ) */ /* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */ /* 10 CONTINUE */
/* 20 CONTINUE */ /* 20 CONTINUE */
/* Note that the imaginary parts of the diagonal elements need */ /* Note that the imaginary parts of the diagonal elements need */
/* not be set and are assumed to be zero. */ /* not be set and are assumed to be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* LDA - INTEGER. */ /* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */ /* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */ /* in the calling (sub) program. LDA must be at least */
/* ( k + 1 ). */ /* ( k + 1 ). */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - COMPLEX*16 array of DIMENSION at least */ /* X - COMPLEX*16 array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the */ /* Before entry, the incremented array X must contain the */
/* vector x. */ /* vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - COMPLEX*16 . */ /* BETA - COMPLEX*16 . */
/* On entry, BETA specifies the scalar beta. */ /* On entry, BETA specifies the scalar beta. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - COMPLEX*16 array of DIMENSION at least */ /* Y - COMPLEX*16 array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the */ /* Before entry, the incremented array Y must contain the */
/* vector y. On exit, Y is overwritten by the updated vector y. */ /* vector y. On exit, Y is overwritten by the updated vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
a_dim1 = *lda; a_dim1 = *lda;
a_offset = 1 + a_dim1; a_offset = 1 + a_dim1;
a -= a_offset; a -= a_offset;
--x; --x;
--y; --y;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("ZHBMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
beta->i == 0.))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0. && alpha->i == 0.) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = i__;
i__3 = i__;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__2 = i__;
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, z__2.i =
z__3.r * x[i__2].i + z__3.i * x[i__2].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L50: */
}
i__4 = j;
i__2 = j;
i__3 = kplus1 + j * a_dim1;
d__1 = a[i__3].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = jx;
z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i =
alpha->r * x[i__4].i + alpha->i * x[i__4].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
z__3.r * x[i__4].i + z__3.i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__3 = jy;
i__4 = jy;
i__2 = kplus1 + j * a_dim1;
d__1 = a[i__2].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = j;
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__3 = j;
i__4 = j;
i__2 = j * a_dim1 + 1;
d__1 = a[i__2].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__2 = i__;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
z__3.r * x[i__4].i + z__3.i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L90: */
}
i__3 = j;
i__4 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = jx;
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__3 = jy;
i__4 = jy;
i__2 = j * a_dim1 + 1;
d__1 = a[i__2].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
z__3.r * x[i__4].i + z__3.i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L110: */
}
i__3 = jy;
i__4 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("ZHBMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of ZHBMV . */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, z__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, z__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0. && alpha->i == 0.) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
i__2 = i__;
i__3 = i__;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__2 = i__;
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, z__2.i = z__3.r * x[i__2].i + z__3.i * x[i__2].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L50: */
}
i__4 = j;
i__2 = j;
i__3 = kplus1 + j * a_dim1;
d__1 = a[i__3].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = jx;
z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i = alpha->r * x[i__4].i + alpha->i * x[i__4].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = z__3.r * x[i__4].i + z__3.i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__3 = jy;
i__4 = jy;
i__2 = kplus1 + j * a_dim1;
d__1 = a[i__2].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = j;
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__3 = j;
i__4 = j;
i__2 = j * a_dim1 + 1;
d__1 = a[i__2].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__2 = i__;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = z__3.r * x[i__4].i + z__3.i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L90: */
}
i__3 = j;
i__4 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = jx;
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__3 = jy;
i__4 = jy;
i__2 = j * a_dim1 + 1;
d__1 = a[i__2].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = z__3.r * x[i__4].i + z__3.i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L110: */
}
i__3 = jy;
i__4 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of ZHBMV . */
} /* zhbmv_ */ } /* zhbmv_ */

767
blas/f2c/zhpmv.c
View File

@ -1,438 +1,407 @@
/* zhpmv.f -- translated by f2c (version 20100827). /* zhpmv.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c: You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib; on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in -- in that order, at the end of the command line, as in
cc *.o -lf2c -lm cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip http://www.netlib.org/f2c/libf2c.zip
*/ */
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int zhpmv_(char *uplo, integer *n, doublecomplex *alpha, /* Subroutine */ int zhpmv_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *ap, doublecomplex *x,
doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex * integer *incx, doublecomplex *beta, doublecomplex *y, integer *incy, ftnlen uplo_len) {
beta, doublecomplex *y, integer *incy, ftnlen uplo_len) /* System generated locals */
{ integer i__1, i__2, i__3, i__4, i__5;
/* System generated locals */ doublereal d__1;
integer i__1, i__2, i__3, i__4, i__5; doublecomplex z__1, z__2, z__3, z__4;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */ /* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */ /* Local variables */
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
doublecomplex temp1, temp2; doublecomplex temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* ZHPMV performs the matrix-vector operation */ /* ZHPMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */ /* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */ /* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n hermitian matrix, supplied in packed form. */ /* A is an n by n hermitian matrix, supplied in packed form. */
/* Arguments */ /* Arguments */
/* ========== */ /* ========== */
/* UPLO - CHARACTER*1. */ /* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */ /* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the matrix A is supplied in the packed */ /* triangular part of the matrix A is supplied in the packed */
/* array AP as follows: */ /* array AP as follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */ /* UPLO = 'U' or 'u' The upper triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */ /* UPLO = 'L' or 'l' The lower triangular part of A is */
/* supplied in AP. */ /* supplied in AP. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* N - INTEGER. */ /* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */ /* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */ /* N must be at least zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* ALPHA - COMPLEX*16 . */ /* ALPHA - COMPLEX*16 . */
/* On entry, ALPHA specifies the scalar alpha. */ /* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* AP - COMPLEX*16 array of DIMENSION at least */ /* AP - COMPLEX*16 array of DIMENSION at least */
/* ( ( n*( n + 1 ) )/2 ). */ /* ( ( n*( n + 1 ) )/2 ). */
/* Before entry with UPLO = 'U' or 'u', the array AP must */ /* Before entry with UPLO = 'U' or 'u', the array AP must */
/* contain the upper triangular part of the hermitian matrix */ /* contain the upper triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
/* and a( 2, 2 ) respectively, and so on. */ /* and a( 2, 2 ) respectively, and so on. */
/* Before entry with UPLO = 'L' or 'l', the array AP must */ /* Before entry with UPLO = 'L' or 'l', the array AP must */
/* contain the lower triangular part of the hermitian matrix */ /* contain the lower triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */ /* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
/* and a( 3, 1 ) respectively, and so on. */ /* and a( 3, 1 ) respectively, and so on. */
/* Note that the imaginary parts of the diagonal elements need */ /* Note that the imaginary parts of the diagonal elements need */
/* not be set and are assumed to be zero. */ /* not be set and are assumed to be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* X - COMPLEX*16 array of dimension at least */ /* X - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */ /* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */ /* Before entry, the incremented array X must contain the n */
/* element vector x. */ /* element vector x. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* INCX - INTEGER. */ /* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */ /* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */ /* X. INCX must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* BETA - COMPLEX*16 . */ /* BETA - COMPLEX*16 . */
/* On entry, BETA specifies the scalar beta. When BETA is */ /* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */ /* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Y - COMPLEX*16 array of dimension at least */ /* Y - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */ /* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the n */ /* Before entry, the incremented array Y must contain the n */
/* element vector y. On exit, Y is overwritten by the updated */ /* element vector y. On exit, Y is overwritten by the updated */
/* vector y. */ /* vector y. */
/* INCY - INTEGER. */ /* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */ /* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */ /* Y. INCY must not be zero. */
/* Unchanged on exit. */ /* Unchanged on exit. */
/* Further Details */ /* Further Details */
/* =============== */ /* =============== */
/* Level 2 Blas routine. */ /* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */ /* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */ /* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */ /* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */ /* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */ /* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */ /* ===================================================================== */
/* .. Parameters .. */ /* .. Parameters .. */
/* .. */ /* .. */
/* .. Local Scalars .. */ /* .. Local Scalars .. */
/* .. */ /* .. */
/* .. External Functions .. */ /* .. External Functions .. */
/* .. */ /* .. */
/* .. External Subroutines .. */ /* .. External Subroutines .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* Test the input parameters. */ /* Test the input parameters. */
/* Parameter adjustments */ /* Parameter adjustments */
--y; --y;
--x; --x;
--ap; --ap;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("ZHPMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
beta->i == 0.))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0. && alpha->i == 0.) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
++k;
/* L50: */
}
i__2 = j;
i__3 = j;
i__4 = kk + j - 1;
d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
i__3 = iy;
i__4 = iy;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__2 = jy;
i__3 = jy;
i__4 = kk + j - 1;
d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = j;
i__3 = j;
i__4 = kk;
d__1 = ap[i__4].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
++k;
/* L90: */
}
i__2 = j;
i__3 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = jy;
i__3 = jy;
i__4 = kk;
d__1 = ap[i__4].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
i__3 = iy;
i__4 = iy;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L110: */
}
i__2 = jy;
i__3 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
/* Function Body */
info = 0;
if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 6;
} else if (*incy == 0) {
info = 9;
}
if (info != 0) {
xerbla_("ZHPMV ", &info, (ftnlen)6);
return 0; return 0;
}
/* End of ZHPMV . */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, z__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, z__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0. && alpha->i == 0.) {
return 0;
}
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
++k;
/* L50: */
}
i__2 = j;
i__3 = j;
i__4 = kk + j - 1;
d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += j;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
i__3 = iy;
i__4 = iy;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__2 = jy;
i__3 = jy;
i__4 = kk + j - 1;
d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
} else {
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = j;
i__3 = j;
i__4 = kk;
d__1 = ap[i__4].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
++k;
/* L90: */
}
i__2 = j;
i__3 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += *n - j + 1;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = jy;
i__3 = jy;
i__4 = kk;
d__1 = ap[i__4].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
iy += *incy;
i__3 = iy;
i__4 = iy;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L110: */
}
i__2 = jy;
i__3 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
return 0;
/* End of ZHPMV . */
} /* zhpmv_ */ } /* zhpmv_ */

1134
blas/f2c/ztbmv.c
View File

File diff suppressed because it is too large Load Diff

71
lapack/cholesky.inc
View File

@ -11,59 +11,62 @@
#include <Eigen/Cholesky> #include <Eigen/Cholesky>
// POTRF computes the Cholesky factorization of a real symmetric positive definite matrix A. // POTRF computes the Cholesky factorization of a real symmetric positive definite matrix A.
EIGEN_LAPACK_FUNC(potrf,(char* uplo, int *n, RealScalar *pa, int *lda, int *info)) EIGEN_LAPACK_FUNC(potrf, (char *uplo, int *n, RealScalar *pa, int *lda, int *info)) {
{
*info = 0; *info = 0;
if(UPLO(*uplo)==INVALID) *info = -1; if (UPLO(*uplo) == INVALID)
else if(*n<0) *info = -2; *info = -1;
else if(*lda<std::max(1,*n)) *info = -4; else if (*n < 0)
if(*info!=0) *info = -2;
{ else if (*lda < std::max(1, *n))
*info = -4;
if (*info != 0) {
int e = -*info; int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"POTRF", &e, 6); return xerbla_(SCALAR_SUFFIX_UP "POTRF", &e, 6);
} }
Scalar* a = reinterpret_cast<Scalar*>(pa); Scalar *a = reinterpret_cast<Scalar *>(pa);
MatrixType A(a,*n,*n,*lda); MatrixType A(a, *n, *n, *lda);
int ret; int ret;
if(UPLO(*uplo)==UP) ret = int(internal::llt_inplace<Scalar, Upper>::blocked(A)); if (UPLO(*uplo) == UP)
else ret = int(internal::llt_inplace<Scalar, Lower>::blocked(A)); ret = int(internal::llt_inplace<Scalar, Upper>::blocked(A));
else
ret = int(internal::llt_inplace<Scalar, Lower>::blocked(A));
if (ret >= 0) *info = ret + 1;
if(ret>=0)
*info = ret+1;
return 0; return 0;
} }
// POTRS solves a system of linear equations A*X = B with a symmetric // POTRS solves a system of linear equations A*X = B with a symmetric
// positive definite matrix A using the Cholesky factorization // positive definite matrix A using the Cholesky factorization
// A = U**T*U or A = L*L**T computed by DPOTRF. // A = U**T*U or A = L*L**T computed by DPOTRF.
EIGEN_LAPACK_FUNC(potrs,(char* uplo, int *n, int *nrhs, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, int *info)) EIGEN_LAPACK_FUNC(potrs,
{ (char *uplo, int *n, int *nrhs, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, int *info)) {
*info = 0; *info = 0;
if(UPLO(*uplo)==INVALID) *info = -1; if (UPLO(*uplo) == INVALID)
else if(*n<0) *info = -2; *info = -1;
else if(*nrhs<0) *info = -3; else if (*n < 0)
else if(*lda<std::max(1,*n)) *info = -5; *info = -2;
else if(*ldb<std::max(1,*n)) *info = -7; else if (*nrhs < 0)
if(*info!=0) *info = -3;
{ else if (*lda < std::max(1, *n))
*info = -5;
else if (*ldb < std::max(1, *n))
*info = -7;
if (*info != 0) {
int e = -*info; int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"POTRS", &e, 6); return xerbla_(SCALAR_SUFFIX_UP "POTRS", &e, 6);
} }
Scalar* a = reinterpret_cast<Scalar*>(pa); Scalar *a = reinterpret_cast<Scalar *>(pa);
Scalar* b = reinterpret_cast<Scalar*>(pb); Scalar *b = reinterpret_cast<Scalar *>(pb);
MatrixType A(a,*n,*n,*lda); MatrixType A(a, *n, *n, *lda);
MatrixType B(b,*n,*nrhs,*ldb); MatrixType B(b, *n, *nrhs, *ldb);
if(UPLO(*uplo)==UP) if (UPLO(*uplo) == UP) {
{
A.triangularView<Upper>().adjoint().solveInPlace(B); A.triangularView<Upper>().adjoint().solveInPlace(B);
A.triangularView<Upper>().solveInPlace(B); A.triangularView<Upper>().solveInPlace(B);
} } else {
else
{
A.triangularView<Lower>().solveInPlace(B); A.triangularView<Lower>().solveInPlace(B);
A.triangularView<Lower>().adjoint().solveInPlace(B); A.triangularView<Lower>().adjoint().solveInPlace(B);
} }

75
lapack/eigenvalues.inc
View File

@ -11,52 +11,53 @@
#include <Eigen/Eigenvalues> #include <Eigen/Eigenvalues>
// computes eigen values and vectors of a general N-by-N matrix A // computes eigen values and vectors of a general N-by-N matrix A
EIGEN_LAPACK_FUNC(syev,(char *jobz, char *uplo, int* n, Scalar* a, int *lda, Scalar* w, Scalar* /*work*/, int* lwork, int *info)) EIGEN_LAPACK_FUNC(syev, (char* jobz, char* uplo, int* n, Scalar* a, int* lda, Scalar* w, Scalar* /*work*/, int* lwork,
{ int* info)) {
// TODO exploit the work buffer // TODO exploit the work buffer
bool query_size = *lwork==-1; bool query_size = *lwork == -1;
*info = 0; *info = 0;
if(*jobz!='N' && *jobz!='V') *info = -1; if (*jobz != 'N' && *jobz != 'V')
else if(UPLO(*uplo)==INVALID) *info = -2; *info = -1;
else if(*n<0) *info = -3; else if (UPLO(*uplo) == INVALID)
else if(*lda<std::max(1,*n)) *info = -5; *info = -2;
else if((!query_size) && *lwork<std::max(1,3**n-1)) *info = -8; else if (*n < 0)
*info = -3;
if(*info!=0) else if (*lda < std::max(1, *n))
{ *info = -5;
else if ((!query_size) && *lwork < std::max(1, 3 * *n - 1))
*info = -8;
if (*info != 0) {
int e = -*info; int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"SYEV ", &e, 6); return xerbla_(SCALAR_SUFFIX_UP "SYEV ", &e, 6);
} }
if(query_size) if (query_size) {
{
*lwork = 0; *lwork = 0;
return 0; return 0;
} }
if(*n==0) if (*n == 0) return 0;
return 0;
PlainMatrixType mat(*n, *n);
PlainMatrixType mat(*n,*n); if (UPLO(*uplo) == UP)
if(UPLO(*uplo)==UP) mat = matrix(a,*n,*n,*lda).adjoint(); mat = matrix(a, *n, *n, *lda).adjoint();
else mat = matrix(a,*n,*n,*lda); else
mat = matrix(a, *n, *n, *lda);
bool computeVectors = *jobz=='V' || *jobz=='v';
SelfAdjointEigenSolver<PlainMatrixType> eig(mat,computeVectors?ComputeEigenvectors:EigenvaluesOnly); bool computeVectors = *jobz == 'V' || *jobz == 'v';
SelfAdjointEigenSolver<PlainMatrixType> eig(mat, computeVectors ? ComputeEigenvectors : EigenvaluesOnly);
if(eig.info()==NoConvergence)
{ if (eig.info() == NoConvergence) {
make_vector(w,*n).setZero(); make_vector(w, *n).setZero();
if(computeVectors) if (computeVectors) matrix(a, *n, *n, *lda).setIdentity();
matrix(a,*n,*n,*lda).setIdentity();
//*info = 1; //*info = 1;
return 0; return 0;
} }
make_vector(w,*n) = eig.eigenvalues(); make_vector(w, *n) = eig.eigenvalues();
if(computeVectors) if (computeVectors) matrix(a, *n, *n, *lda) = eig.eigenvectors();
matrix(a,*n,*n,*lda) = eig.eigenvectors();
return 0; return 0;
} }

93
lapack/lu.inc
View File

@ -11,79 +11,74 @@
#include <Eigen/LU> #include <Eigen/LU>
// computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges // computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges
EIGEN_LAPACK_FUNC(getrf,(int *m, int *n, RealScalar *pa, int *lda, int *ipiv, int *info)) EIGEN_LAPACK_FUNC(getrf, (int *m, int *n, RealScalar *pa, int *lda, int *ipiv, int *info)) {
{
*info = 0; *info = 0;
if(*m<0) *info = -1; if (*m < 0)
else if(*n<0) *info = -2; *info = -1;
else if(*lda<std::max(1,*m)) *info = -4; else if (*n < 0)
if(*info!=0) *info = -2;
{ else if (*lda < std::max(1, *m))
*info = -4;
if (*info != 0) {
int e = -*info; int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"GETRF", &e, 6); return xerbla_(SCALAR_SUFFIX_UP "GETRF", &e, 6);
} }
if(*m==0 || *n==0) if (*m == 0 || *n == 0) return 0;
return 0;
Scalar* a = reinterpret_cast<Scalar*>(pa); Scalar *a = reinterpret_cast<Scalar *>(pa);
int nb_transpositions; int nb_transpositions;
int ret = int(Eigen::internal::partial_lu_impl<Scalar,ColMajor,int> int ret = int(
::blocked_lu(*m, *n, a, *lda, ipiv, nb_transpositions)); Eigen::internal::partial_lu_impl<Scalar, ColMajor, int>::blocked_lu(*m, *n, a, *lda, ipiv, nb_transpositions));
for(int i=0; i<std::min(*m,*n); ++i) for (int i = 0; i < std::min(*m, *n); ++i) ipiv[i]++;
ipiv[i]++;
if(ret>=0) if (ret >= 0) *info = ret + 1;
*info = ret+1;
return 0; return 0;
} }
//GETRS solves a system of linear equations // GETRS solves a system of linear equations
// A * X = B or A' * X = B // A * X = B or A' * X = B
// with a general N-by-N matrix A using the LU factorization computed by GETRF // with a general N-by-N matrix A using the LU factorization computed by GETRF
EIGEN_LAPACK_FUNC(getrs,(char *trans, int *n, int *nrhs, RealScalar *pa, int *lda, int *ipiv, RealScalar *pb, int *ldb, int *info)) EIGEN_LAPACK_FUNC(getrs, (char *trans, int *n, int *nrhs, RealScalar *pa, int *lda, int *ipiv, RealScalar *pb, int *ldb,
{ int *info)) {
*info = 0; *info = 0;
if(OP(*trans)==INVALID) *info = -1; if (OP(*trans) == INVALID)
else if(*n<0) *info = -2; *info = -1;
else if(*nrhs<0) *info = -3; else if (*n < 0)
else if(*lda<std::max(1,*n)) *info = -5; *info = -2;
else if(*ldb<std::max(1,*n)) *info = -8; else if (*nrhs < 0)
if(*info!=0) *info = -3;
{ else if (*lda < std::max(1, *n))
*info = -5;
else if (*ldb < std::max(1, *n))
*info = -8;
if (*info != 0) {
int e = -*info; int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"GETRS", &e, 6); return xerbla_(SCALAR_SUFFIX_UP "GETRS", &e, 6);
} }
Scalar* a = reinterpret_cast<Scalar*>(pa); Scalar *a = reinterpret_cast<Scalar *>(pa);
Scalar* b = reinterpret_cast<Scalar*>(pb); Scalar *b = reinterpret_cast<Scalar *>(pb);
MatrixType lu(a,*n,*n,*lda); MatrixType lu(a, *n, *n, *lda);
MatrixType B(b,*n,*nrhs,*ldb); MatrixType B(b, *n, *nrhs, *ldb);
for(int i=0; i<*n; ++i) for (int i = 0; i < *n; ++i) ipiv[i]--;
ipiv[i]--; if (OP(*trans) == NOTR) {
if(OP(*trans)==NOTR) B = PivotsType(ipiv, *n) * B;
{
B = PivotsType(ipiv,*n) * B;
lu.triangularView<UnitLower>().solveInPlace(B); lu.triangularView<UnitLower>().solveInPlace(B);
lu.triangularView<Upper>().solveInPlace(B); lu.triangularView<Upper>().solveInPlace(B);
} } else if (OP(*trans) == TR) {
else if(OP(*trans)==TR)
{
lu.triangularView<Upper>().transpose().solveInPlace(B); lu.triangularView<Upper>().transpose().solveInPlace(B);
lu.triangularView<UnitLower>().transpose().solveInPlace(B); lu.triangularView<UnitLower>().transpose().solveInPlace(B);
B = PivotsType(ipiv,*n).transpose() * B; B = PivotsType(ipiv, *n).transpose() * B;
} } else if (OP(*trans) == ADJ) {
else if(OP(*trans)==ADJ)
{
lu.triangularView<Upper>().adjoint().solveInPlace(B); lu.triangularView<Upper>().adjoint().solveInPlace(B);
lu.triangularView<UnitLower>().adjoint().solveInPlace(B); lu.triangularView<UnitLower>().adjoint().solveInPlace(B);
B = PivotsType(ipiv,*n).transpose() * B; B = PivotsType(ipiv, *n).transpose() * B;
} }
for(int i=0; i<*n; ++i) for (int i = 0; i < *n; ++i) ipiv[i]++;
ipiv[i]++;
return 0; return 0;
} }

203
lapack/svd.inc
View File

@ -11,128 +11,135 @@
#include <Eigen/SVD> #include <Eigen/SVD>
// computes the singular values/vectors a general M-by-N matrix A using divide-and-conquer // computes the singular values/vectors a general M-by-N matrix A using divide-and-conquer
EIGEN_LAPACK_FUNC(gesdd,(char *jobz, int *m, int* n, Scalar* a, int *lda, RealScalar *s, Scalar *u, int *ldu, Scalar *vt, int *ldvt, Scalar* /*work*/, int* lwork, EIGEN_LAPACK_FUNC(gesdd, (char *jobz, int *m, int *n, Scalar *a, int *lda, RealScalar *s, Scalar *u, int *ldu,
EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar */*rwork*/) int * /*iwork*/, int *info)) Scalar *vt, int *ldvt, Scalar * /*work*/, int *lwork,
{ EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar * /*rwork*/) int * /*iwork*/, int *info)) {
// TODO exploit the work buffer // TODO exploit the work buffer
bool query_size = *lwork==-1; bool query_size = *lwork == -1;
int diag_size = (std::min)(*m,*n); int diag_size = (std::min)(*m, *n);
*info = 0; *info = 0;
if(*jobz!='A' && *jobz!='S' && *jobz!='O' && *jobz!='N') *info = -1; if (*jobz != 'A' && *jobz != 'S' && *jobz != 'O' && *jobz != 'N')
else if(*m<0) *info = -2; *info = -1;
else if(*n<0) *info = -3; else if (*m < 0)
else if(*lda<std::max(1,*m)) *info = -5; *info = -2;
else if(*lda<std::max(1,*m)) *info = -8; else if (*n < 0)
else if(*ldu <1 || (*jobz=='A' && *ldu <*m) *info = -3;
|| (*jobz=='O' && *m<*n && *ldu<*m)) *info = -8; else if (*lda < std::max(1, *m))
else if(*ldvt<1 || (*jobz=='A' && *ldvt<*n) *info = -5;
|| (*jobz=='S' && *ldvt<diag_size) else if (*lda < std::max(1, *m))
|| (*jobz=='O' && *m>=*n && *ldvt<*n)) *info = -10; *info = -8;
else if (*ldu < 1 || (*jobz == 'A' && *ldu < *m) || (*jobz == 'O' && *m < *n && *ldu < *m))
if(*info!=0) *info = -8;
{ else if (*ldvt < 1 || (*jobz == 'A' && *ldvt < *n) || (*jobz == 'S' && *ldvt < diag_size) ||
(*jobz == 'O' && *m >= *n && *ldvt < *n))
*info = -10;
if (*info != 0) {
int e = -*info; int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"GESDD ", &e, 6); return xerbla_(SCALAR_SUFFIX_UP "GESDD ", &e, 6);
} }
if(query_size) if (query_size) {
{
*lwork = 0; *lwork = 0;
return 0; return 0;
} }
if(*n==0 || *m==0)
return 0;
PlainMatrixType mat(*m,*n);
mat = matrix(a,*m,*n,*lda);
int option = *jobz=='A' ? ComputeFullU|ComputeFullV
: *jobz=='S' ? ComputeThinU|ComputeThinV
: *jobz=='O' ? ComputeThinU|ComputeThinV
: 0;
BDCSVD<PlainMatrixType> svd(mat,option); if (*n == 0 || *m == 0) return 0;
make_vector(s,diag_size) = svd.singularValues().head(diag_size);
if(*jobz=='A') PlainMatrixType mat(*m, *n);
{ mat = matrix(a, *m, *n, *lda);
matrix(u,*m,*m,*ldu) = svd.matrixU();
matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint(); int option = *jobz == 'A' ? ComputeFullU | ComputeFullV
: *jobz == 'S' ? ComputeThinU | ComputeThinV
: *jobz == 'O' ? ComputeThinU | ComputeThinV
: 0;
BDCSVD<PlainMatrixType> svd(mat, option);
make_vector(s, diag_size) = svd.singularValues().head(diag_size);
if (*jobz == 'A') {
matrix(u, *m, *m, *ldu) = svd.matrixU();
matrix(vt, *n, *n, *ldvt) = svd.matrixV().adjoint();
} else if (*jobz == 'S') {
matrix(u, *m, diag_size, *ldu) = svd.matrixU();
matrix(vt, diag_size, *n, *ldvt) = svd.matrixV().adjoint();
} else if (*jobz == 'O' && *m >= *n) {
matrix(a, *m, *n, *lda) = svd.matrixU();
matrix(vt, *n, *n, *ldvt) = svd.matrixV().adjoint();
} else if (*jobz == 'O') {
matrix(u, *m, *m, *ldu) = svd.matrixU();
matrix(a, diag_size, *n, *lda) = svd.matrixV().adjoint();
} }
else if(*jobz=='S')
{
matrix(u,*m,diag_size,*ldu) = svd.matrixU();
matrix(vt,diag_size,*n,*ldvt) = svd.matrixV().adjoint();
}
else if(*jobz=='O' && *m>=*n)
{
matrix(a,*m,*n,*lda) = svd.matrixU();
matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint();
}
else if(*jobz=='O')
{
matrix(u,*m,*m,*ldu) = svd.matrixU();
matrix(a,diag_size,*n,*lda) = svd.matrixV().adjoint();
}
return 0; return 0;
} }
// computes the singular values/vectors a general M-by-N matrix A using two sided jacobi algorithm // computes the singular values/vectors a general M-by-N matrix A using two sided jacobi algorithm
EIGEN_LAPACK_FUNC(gesvd,(char *jobu, char *jobv, int *m, int* n, Scalar* a, int *lda, RealScalar *s, Scalar *u, int *ldu, Scalar *vt, int *ldvt, Scalar* /*work*/, int* lwork, EIGEN_LAPACK_FUNC(gesvd, (char *jobu, char *jobv, int *m, int *n, Scalar *a, int *lda, RealScalar *s, Scalar *u,
EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar */*rwork*/) int *info)) int *ldu, Scalar *vt, int *ldvt, Scalar * /*work*/, int *lwork,
{ EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar * /*rwork*/) int *info)) {
// TODO exploit the work buffer // TODO exploit the work buffer
bool query_size = *lwork==-1; bool query_size = *lwork == -1;
int diag_size = (std::min)(*m,*n); int diag_size = (std::min)(*m, *n);
*info = 0; *info = 0;
if( *jobu!='A' && *jobu!='S' && *jobu!='O' && *jobu!='N') *info = -1; if (*jobu != 'A' && *jobu != 'S' && *jobu != 'O' && *jobu != 'N')
else if((*jobv!='A' && *jobv!='S' && *jobv!='O' && *jobv!='N') *info = -1;
|| (*jobu=='O' && *jobv=='O')) *info = -2; else if ((*jobv != 'A' && *jobv != 'S' && *jobv != 'O' && *jobv != 'N') || (*jobu == 'O' && *jobv == 'O'))
else if(*m<0) *info = -3; *info = -2;
else if(*n<0) *info = -4; else if (*m < 0)
else if(*lda<std::max(1,*m)) *info = -6; *info = -3;
else if(*ldu <1 || ((*jobu=='A' || *jobu=='S') && *ldu<*m)) *info = -9; else if (*n < 0)
else if(*ldvt<1 || (*jobv=='A' && *ldvt<*n) *info = -4;
|| (*jobv=='S' && *ldvt<diag_size)) *info = -11; else if (*lda < std::max(1, *m))
*info = -6;
if(*info!=0) else if (*ldu < 1 || ((*jobu == 'A' || *jobu == 'S') && *ldu < *m))
{ *info = -9;
else if (*ldvt < 1 || (*jobv == 'A' && *ldvt < *n) || (*jobv == 'S' && *ldvt < diag_size))
*info = -11;
if (*info != 0) {
int e = -*info; int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"GESVD ", &e, 6); return xerbla_(SCALAR_SUFFIX_UP "GESVD ", &e, 6);
} }
if(query_size) if (query_size) {
{
*lwork = 0; *lwork = 0;
return 0; return 0;
} }
if(*n==0 || *m==0) if (*n == 0 || *m == 0) return 0;
return 0;
PlainMatrixType mat(*m, *n);
PlainMatrixType mat(*m,*n); mat = matrix(a, *m, *n, *lda);
mat = matrix(a,*m,*n,*lda);
int option = (*jobu == 'A' ? ComputeFullU
int option = (*jobu=='A' ? ComputeFullU : *jobu=='S' || *jobu=='O' ? ComputeThinU : 0) : *jobu == 'S' || *jobu == 'O' ? ComputeThinU
| (*jobv=='A' ? ComputeFullV : *jobv=='S' || *jobv=='O' ? ComputeThinV : 0); : 0) |
(*jobv == 'A' ? ComputeFullV
JacobiSVD<PlainMatrixType> svd(mat,option); : *jobv == 'S' || *jobv == 'O' ? ComputeThinV
: 0);
make_vector(s,diag_size) = svd.singularValues().head(diag_size);
JacobiSVD<PlainMatrixType> svd(mat, option);
make_vector(s, diag_size) = svd.singularValues().head(diag_size);
{ {
if(*jobu=='A') matrix(u,*m,*m,*ldu) = svd.matrixU(); if (*jobu == 'A')
else if(*jobu=='S') matrix(u,*m,diag_size,*ldu) = svd.matrixU(); matrix(u, *m, *m, *ldu) = svd.matrixU();
else if(*jobu=='O') matrix(a,*m,diag_size,*lda) = svd.matrixU(); else if (*jobu == 'S')
matrix(u, *m, diag_size, *ldu) = svd.matrixU();
else if (*jobu == 'O')
matrix(a, *m, diag_size, *lda) = svd.matrixU();
} }
{ {
if(*jobv=='A') matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint(); if (*jobv == 'A')
else if(*jobv=='S') matrix(vt,diag_size,*n,*ldvt) = svd.matrixV().adjoint(); matrix(vt, *n, *n, *ldvt) = svd.matrixV().adjoint();
else if(*jobv=='O') matrix(a,diag_size,*n,*lda) = svd.matrixV().adjoint(); else if (*jobv == 'S')
matrix(vt, diag_size, *n, *ldvt) = svd.matrixV().adjoint();
else if (*jobv == 'O')
matrix(a, diag_size, *n, *lda) = svd.matrixV().adjoint();
} }
return 0; return 0;
} }