GitHub-Proxy/eigen
1
0
Fork 0
mirror of https://gitlab.com/libeigen/eigen.git synced 2025-07-21 20:34:28 +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

357
blas/f2c/chbmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1; real r__1;
@ -31,148 +29,148 @@
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;
@ -183,8 +181,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -202,14 +199,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && beta->i == 0.f))) {
beta->i == 0.f))) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -222,10 +218,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array A */ /* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */ /* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (beta->r != 1.f || beta->i != 0.f) { if (beta->r != 1.f || beta->i != 0.f) {
if (*incy == 1) { if (*incy == 1) {
@ -234,18 +230,16 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f; y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
q__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -256,19 +250,17 @@
i__2 = iy; i__2 = iy;
y[i__2].r = 0.f, y[i__2].i = 0.f; y[i__2].r = 0.f, y[i__2].i = 0.f;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy; i__2 = iy;
i__3 = iy; i__3 = iy;
q__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -277,38 +269,33 @@
return 0; return 0;
} }
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1; kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j; i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__2 = i__; i__2 = i__;
q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
/* L50: */ /* L50: */
} }
i__4 = j; i__4 = j;
i__2 = j; i__2 = j;
@ -316,11 +303,10 @@
r__1 = a[i__3].r; r__1 = a[i__3].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; 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__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 = q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__4].r = q__1.r, y[i__4].i = q__1.i;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -328,34 +314,30 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__4 = jx; i__4 = jx;
q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i = 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;
alpha->r * x[i__4].i + alpha->i * x[i__4].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
ix = kx; ix = kx;
iy = ky; iy = ky;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
i__4 = iy; i__4 = iy;
i__2 = iy; i__2 = iy;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix; i__4 = ix;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
i__3 = jy; i__3 = jy;
i__4 = jy; i__4 = jy;
@ -363,8 +345,7 @@
r__1 = a[i__2].r; r__1 = a[i__2].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; 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__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 = q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx; jx += *incx;
@ -373,19 +354,17 @@
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
} }
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when lower triangle of A is stored. */
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__3 = j; i__3 = j;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = 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;
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
i__3 = j; i__3 = j;
@ -396,33 +375,29 @@
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__; i__4 = i__;
i__2 = i__; i__2 = i__;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = i__; i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
/* L90: */ /* L90: */
} }
i__3 = j; i__3 = j;
i__4 = j; i__4 = j;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -430,8 +405,7 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__3 = jx; i__3 = jx;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = 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;
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
i__3 = jy; i__3 = jy;
@ -444,44 +418,39 @@
l = 1 - j; l = 1 - j;
ix = jx; ix = jx;
iy = jy; iy = jy;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
i__4 = iy; i__4 = iy;
i__2 = iy; i__2 = iy;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix; i__4 = ix;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
/* L110: */ /* L110: */
} }
i__3 = jy; i__3 = jy;
i__4 = jy; i__4 = jy;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of CHBMV . */ /* End of CHBMV . */
} /* chbmv_ */ } /* chbmv_ */

285
blas/f2c/chpmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* System generated locals */
integer i__1, i__2, i__3, i__4, i__5; integer i__1, i__2, i__3, i__4, i__5;
real r__1; real r__1;
@ -30,114 +28,114 @@
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;
@ -146,8 +144,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -161,14 +158,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && beta->i == 0.f))) {
beta->i == 0.f))) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -181,10 +177,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array AP */ /* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */ /* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (beta->r != 1.f || beta->i != 0.f) { if (beta->r != 1.f || beta->i != 0.f) {
if (*incy == 1) { if (*incy == 1) {
@ -193,18 +189,16 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f; y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
q__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -215,19 +209,17 @@
i__2 = iy; i__2 = iy;
y[i__2].r = 0.f, y[i__2].i = 0.f; y[i__2].r = 0.f, y[i__2].i = 0.f;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy; i__2 = iy;
i__3 = iy; i__3 = iy;
q__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -237,15 +229,13 @@
} }
kk = 1; kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j; i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
k = kk; k = kk;
@ -254,19 +244,16 @@
i__3 = i__; i__3 = i__;
i__4 = i__; i__4 = i__;
i__5 = k; i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]); r_cnjg(&q__3, &ap[k]);
i__3 = i__; i__3 = i__;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
++k; ++k;
/* L50: */ /* L50: */
} }
i__2 = j; i__2 = j;
i__3 = j; i__3 = j;
@ -274,12 +261,11 @@
r__1 = ap[i__4].r; r__1 = ap[i__4].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; 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__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 = q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
kk += j; kk += j;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -287,8 +273,7 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = jx; i__2 = jx;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
ix = kx; ix = kx;
@ -298,20 +283,17 @@
i__3 = iy; i__3 = iy;
i__4 = iy; i__4 = iy;
i__5 = k; i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]); r_cnjg(&q__3, &ap[k]);
i__3 = ix; i__3 = ix;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
i__2 = jy; i__2 = jy;
i__3 = jy; i__3 = jy;
@ -319,26 +301,23 @@
r__1 = ap[i__4].r; r__1 = ap[i__4].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; 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__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 = q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += j; kk += j;
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when AP contains the lower triangle. */
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j; i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
i__2 = j; i__2 = j;
@ -354,28 +333,24 @@
i__3 = i__; i__3 = i__;
i__4 = i__; i__4 = i__;
i__5 = k; i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]); r_cnjg(&q__3, &ap[k]);
i__3 = i__; i__3 = i__;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
++k; ++k;
/* L90: */ /* L90: */
} }
i__2 = j; i__2 = j;
i__3 = j; i__3 = j;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
kk += *n - j + 1; kk += *n - j + 1;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -383,8 +358,7 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = jx; i__2 = jx;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i; temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f; temp2.r = 0.f, temp2.i = 0.f;
i__2 = jy; i__2 = jy;
@ -403,36 +377,31 @@
i__3 = iy; i__3 = iy;
i__4 = iy; i__4 = iy;
i__5 = k; i__5 = k;
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = q__1.r, y[i__3].i = q__1.i;
r_cnjg(&q__3, &ap[k]); r_cnjg(&q__3, &ap[k]);
i__3 = ix; i__3 = ix;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.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__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; 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; temp2.r = q__1.r, temp2.i = q__1.i;
/* L110: */ /* L110: */
} }
i__2 = jy; i__2 = jy;
i__3 = jy; i__3 = jy;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = q__1.r, y[i__2].i = q__1.i;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += *n - j + 1; kk += *n - j + 1;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of CHPMV . */ /* End of CHPMV . */
} /* chpmv_ */ } /* chpmv_ */

31
blas/f2c/complexdots.c
View File

@ -18,12 +18,9 @@
#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; complex res;
extern /* Subroutine */ int cdotcw_(integer *, complex *, integer *, extern /* Subroutine */ int cdotcw_(integer *, complex *, integer *, complex *, integer *, complex *);
complex *, integer *, complex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
@ -34,12 +31,9 @@ complex cdotc_(integer *n, complex *cx, integer
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; complex res;
extern /* Subroutine */ int cdotuw_(integer *, complex *, integer *, extern /* Subroutine */ int cdotuw_(integer *, complex *, integer *, complex *, integer *, complex *);
complex *, integer *, complex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
@ -50,12 +44,10 @@ complex cdotu_(integer *n, complex *cx, integer
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; doublecomplex res;
extern /* Subroutine */ int zdotcw_(integer *, doublecomplex *, integer *, extern /* Subroutine */ int zdotcw_(integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *); doublecomplex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
@ -66,12 +58,10 @@ doublecomplex zdotc_(integer *n, doublecomplex *cx, integer *incx,
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; doublecomplex res;
extern /* Subroutine */ int zdotuw_(integer *, doublecomplex *, integer *, extern /* Subroutine */ int zdotuw_(integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *); doublecomplex *);
/* Parameter adjustments */ /* Parameter adjustments */
--cy; --cy;
@ -81,4 +71,3 @@ doublecomplex zdotu_(integer *n, doublecomplex *cx, integer *incx,
zdotuw_(n, &cx[1], incx, &cy[1], incy, &res); zdotuw_(n, &cx[1], incx, &cy[1], incy, &res);
return res; return res;
} /* zdotu_ */ } /* zdotu_ */

492
blas/f2c/ctbmv.c
View File

@ -12,10 +12,8 @@
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n, /* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, complex *a, integer *lda,
integer *k, complex *a, integer *lda, complex *x, integer *incx, complex *x, integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) {
ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
{
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1, q__2, q__3; complex q__1, q__2, q__3;
@ -31,154 +29,154 @@
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical noconj, nounit; logical noconj, nounit;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* CTBMV performs one of the matrix-vector operations */ /* CTBMV performs one of the matrix-vector operations */
/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ /* x := A*x, or x := A'*x, or x := conjg( 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 := conjg( A' )*x. */ /* TRANS = 'C' or 'c' x := conjg( 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 - 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 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 - 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. 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;
@ -188,15 +186,12 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, } else if (!lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && !lsame_(trans, "T", (ftnlen)1, (ftnlen)1) &&
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( !lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
ftnlen)1)) {
info = 2; info = 2;
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, } else if (!lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && !lsame_(diag, "N", (ftnlen)1, (ftnlen)1)) {
"N", (ftnlen)1, (ftnlen)1)) {
info = 3; info = 3;
} else if (*n < 0) { } else if (*n < 0) {
info = 4; info = 4;
@ -212,7 +207,7 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
@ -221,8 +216,8 @@
noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1); noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* Set up the start point in X if the increment is not unity. This */ /* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */ /* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 0) { if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx; kx = 1 - (*n - 1) * *incx;
@ -230,12 +225,11 @@
kx = 1; kx = 1;
} }
/* Start the operations. In this version the elements of A are */ /* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */ /* accessed sequentially with one pass through A. */
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -247,32 +241,28 @@
i__2 = j; i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i; temp.r = x[i__2].r, temp.i = x[i__2].i;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, q__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r;
q__2.i = temp.r * a[i__5].i + temp.i * a[ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + q__2.i;
i__5].r;
q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
q__2.i;
x[i__2].r = q__1.r, x[i__2].i = q__1.i; x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/* L10: */ /* L10: */
} }
if (nounit) { if (nounit) {
i__4 = j; i__4 = j;
i__2 = j; i__2 = j;
i__3 = kplus1 + j * a_dim1; i__3 = kplus1 + j * a_dim1;
q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[i__3].i,
i__3].i, q__1.i = x[i__2].r * a[i__3].i + q__1.i = x[i__2].r * a[i__3].i + x[i__2].i * a[i__3].r;
x[i__2].i * a[i__3].r;
x[i__4].r = q__1.r, x[i__4].i = q__1.i; x[i__4].r = q__1.r, x[i__4].i = q__1.i;
} }
} }
/* L20: */ /* L20: */
} }
} else { } else {
jx = kx; jx = kx;
@ -284,29 +274,25 @@
temp.r = x[i__4].r, temp.i = x[i__4].i; temp.r = x[i__4].r, temp.i = x[i__4].i;
ix = kx; ix = kx;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
i__4 = ix; i__4 = ix;
i__2 = ix; i__2 = ix;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, q__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r;
q__2.i = temp.r * a[i__5].i + temp.i * a[ q__1.r = x[i__2].r + q__2.r, q__1.i = x[i__2].i + q__2.i;
i__5].r;
q__1.r = x[i__2].r + q__2.r, q__1.i = x[i__2].i +
q__2.i;
x[i__4].r = q__1.r, x[i__4].i = q__1.i; x[i__4].r = q__1.r, x[i__4].i = q__1.i;
ix += *incx; ix += *incx;
/* L30: */ /* L30: */
} }
if (nounit) { if (nounit) {
i__3 = jx; i__3 = jx;
i__4 = jx; i__4 = jx;
i__2 = kplus1 + j * a_dim1; i__2 = kplus1 + j * a_dim1;
q__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[ q__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[i__2].i,
i__2].i, q__1.i = x[i__4].r * a[i__2].i + q__1.i = x[i__4].r * a[i__2].i + x[i__4].i * a[i__2].r;
x[i__4].i * a[i__2].r;
x[i__3].r = q__1.r, x[i__3].i = q__1.i; x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} }
} }
@ -314,7 +300,7 @@
if (j > *k) { if (j > *k) {
kx += *incx; kx += *incx;
} }
/* L40: */ /* L40: */
} }
} }
} else { } else {
@ -325,32 +311,28 @@
i__1 = j; i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i; temp.r = x[i__1].r, temp.i = x[i__1].i;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__3 = j + *k; i__1 = *n, i__3 = j + *k;
i__4 = j + 1; i__4 = j + 1;
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { for (i__ = min(i__1, i__3); i__ >= i__4; --i__) {
i__1 = i__; i__1 = i__;
i__3 = i__; i__3 = i__;
i__2 = l + i__ + j * a_dim1; i__2 = l + i__ + j * a_dim1;
q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, q__2.i = temp.r * a[i__2].i + temp.i * a[i__2].r;
q__2.i = temp.r * a[i__2].i + temp.i * a[ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + q__2.i;
i__2].r;
q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
q__2.i;
x[i__1].r = q__1.r, x[i__1].i = q__1.i; x[i__1].r = q__1.r, x[i__1].i = q__1.i;
/* L50: */ /* L50: */
} }
if (nounit) { if (nounit) {
i__4 = j; i__4 = j;
i__1 = j; i__1 = j;
i__3 = j * a_dim1 + 1; i__3 = j * a_dim1 + 1;
q__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[ q__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[i__3].i,
i__3].i, q__1.i = x[i__1].r * a[i__3].i + q__1.i = x[i__1].r * a[i__3].i + x[i__1].i * a[i__3].r;
x[i__1].i * a[i__3].r;
x[i__4].r = q__1.r, x[i__4].i = q__1.i; x[i__4].r = q__1.r, x[i__4].i = q__1.i;
} }
} }
/* L60: */ /* L60: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -362,29 +344,25 @@
temp.r = x[i__4].r, temp.i = x[i__4].i; temp.r = x[i__4].r, temp.i = x[i__4].i;
ix = kx; ix = kx;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__1 = j + *k; i__4 = *n, i__1 = j + *k;
i__3 = j + 1; i__3 = j + 1;
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { for (i__ = min(i__4, i__1); i__ >= i__3; --i__) {
i__4 = ix; i__4 = ix;
i__1 = ix; i__1 = ix;
i__2 = l + i__ + j * a_dim1; i__2 = l + i__ + j * a_dim1;
q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, q__2.i = temp.r * a[i__2].i + temp.i * a[i__2].r;
q__2.i = temp.r * a[i__2].i + temp.i * a[ q__1.r = x[i__1].r + q__2.r, q__1.i = x[i__1].i + q__2.i;
i__2].r;
q__1.r = x[i__1].r + q__2.r, q__1.i = x[i__1].i +
q__2.i;
x[i__4].r = q__1.r, x[i__4].i = q__1.i; x[i__4].r = q__1.r, x[i__4].i = q__1.i;
ix -= *incx; ix -= *incx;
/* L70: */ /* L70: */
} }
if (nounit) { if (nounit) {
i__3 = jx; i__3 = jx;
i__4 = jx; i__4 = jx;
i__1 = j * a_dim1 + 1; i__1 = j * a_dim1 + 1;
q__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[ q__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[i__1].i,
i__1].i, q__1.i = x[i__4].r * a[i__1].i + q__1.i = x[i__4].r * a[i__1].i + x[i__4].i * a[i__1].r;
x[i__4].i * a[i__1].r;
x[i__3].r = q__1.r, x[i__3].i = q__1.i; x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} }
} }
@ -392,13 +370,12 @@
if (*n - j >= *k) { if (*n - j >= *k) {
kx -= *incx; kx -= *incx;
} }
/* L80: */ /* L80: */
} }
} }
} }
} else { } else {
/* Form x := A'*x or x := conjg( A' )*x. */
/* Form x := A'*x or x := conjg( A' )*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -410,51 +387,42 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__3 = kplus1 + j * a_dim1; i__3 = kplus1 + j * a_dim1;
q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, q__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r;
q__1.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
i__4 = l + i__ + j * a_dim1; i__4 = l + i__ + j * a_dim1;
i__1 = i__; i__1 = i__;
q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[i__1].i,
i__1].i, q__2.i = a[i__4].r * x[i__1].i + q__2.i = a[i__4].r * x[i__1].i + a[i__4].i * x[i__1].r;
a[i__4].i * x[i__1].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
/* L90: */ /* L90: */
} }
} else { } else {
if (nounit) { if (nounit) {
r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r;
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = i__; i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[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__2.i = q__3.r * x[i__4].i + q__3.i * x[ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
i__4].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
/* L100: */ /* L100: */
} }
} }
i__3 = j; i__3 = j;
x[i__3].r = temp.r, x[i__3].i = temp.i; x[i__3].r = temp.r, x[i__3].i = temp.i;
/* L110: */ /* L110: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -468,54 +436,45 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__3 = kplus1 + j * a_dim1; i__3 = kplus1 + j * a_dim1;
q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, q__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r;
q__1.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
i__4 = l + i__ + j * a_dim1; i__4 = l + i__ + j * a_dim1;
i__1 = ix; i__1 = ix;
q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[i__1].i,
i__1].i, q__2.i = a[i__4].r * x[i__1].i + q__2.i = a[i__4].r * x[i__1].i + a[i__4].i * x[i__1].r;
a[i__4].i * x[i__1].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
ix -= *incx; ix -= *incx;
/* L120: */ /* L120: */
} }
} else { } else {
if (nounit) { if (nounit) {
r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r;
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix; i__4 = ix;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[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__2.i = q__3.r * x[i__4].i + q__3.i * x[ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
i__4].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
ix -= *incx; ix -= *incx;
/* L130: */ /* L130: */
} }
} }
i__3 = jx; i__3 = jx;
x[i__3].r = temp.r, x[i__3].i = temp.i; x[i__3].r = temp.r, x[i__3].i = temp.i;
jx -= *incx; jx -= *incx;
/* L140: */ /* L140: */
} }
} }
} else { } else {
@ -528,51 +487,42 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__4 = j * a_dim1 + 1; i__4 = j * a_dim1 + 1;
q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, q__1.i = temp.r * a[i__4].i + temp.i * a[i__4].r;
q__1.i = temp.r * a[i__4].i + temp.i * a[
i__4].r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
i__1 = l + i__ + j * a_dim1; i__1 = l + i__ + j * a_dim1;
i__2 = i__; i__2 = i__;
q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[i__2].i,
i__2].i, q__2.i = a[i__1].r * x[i__2].i + q__2.i = a[i__1].r * x[i__2].i + a[i__1].i * x[i__2].r;
a[i__1].i * x[i__2].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
/* L150: */ /* L150: */
} }
} else { } else {
if (nounit) { if (nounit) {
r_cnjg(&q__2, &a[j * a_dim1 + 1]); r_cnjg(&q__2, &a[j * a_dim1 + 1]);
q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r;
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__1 = i__; i__1 = i__;
q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, q__2.i = q__3.r * x[i__1].i + q__3.i * x[i__1].r;
q__2.i = q__3.r * x[i__1].i + q__3.i * x[ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
i__1].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
/* L160: */ /* L160: */
} }
} }
i__4 = j; i__4 = j;
x[i__4].r = temp.r, x[i__4].i = temp.i; x[i__4].r = temp.r, x[i__4].i = temp.i;
/* L170: */ /* L170: */
} }
} else { } else {
jx = kx; jx = kx;
@ -586,54 +536,45 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__4 = j * a_dim1 + 1; i__4 = j * a_dim1 + 1;
q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, q__1.i = temp.r * a[i__4].i + temp.i * a[i__4].r;
q__1.i = temp.r * a[i__4].i + temp.i * a[
i__4].r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
i__1 = l + i__ + j * a_dim1; i__1 = l + i__ + j * a_dim1;
i__2 = ix; i__2 = ix;
q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[i__2].i,
i__2].i, q__2.i = a[i__1].r * x[i__2].i + q__2.i = a[i__1].r * x[i__2].i + a[i__1].i * x[i__2].r;
a[i__1].i * x[i__2].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
ix += *incx; ix += *incx;
/* L180: */ /* L180: */
} }
} else { } else {
if (nounit) { if (nounit) {
r_cnjg(&q__2, &a[j * a_dim1 + 1]); r_cnjg(&q__2, &a[j * a_dim1 + 1]);
q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r;
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__1 = ix; i__1 = ix;
q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, q__2.i = q__3.r * x[i__1].i + q__3.i * x[i__1].r;
q__2.i = q__3.r * x[i__1].i + q__3.i * x[ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
i__1].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i; temp.r = q__1.r, temp.i = q__1.i;
ix += *incx; ix += *incx;
/* L190: */ /* L190: */
} }
} }
i__4 = jx; i__4 = jx;
x[i__4].r = temp.r, x[i__4].i = temp.i; x[i__4].r = temp.r, x[i__4].i = temp.i;
jx += *incx; jx += *incx;
/* L200: */ /* L200: */
} }
} }
} }
@ -641,7 +582,6 @@
return 0; return 0;
/* End of CTBMV . */ /* End of CTBMV . */
} /* ctbmv_ */ } /* ctbmv_ */

100
blas/f2c/drotm.c
View File

@ -12,9 +12,8 @@
#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.;
@ -30,73 +29,73 @@
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;
} }
@ -118,7 +117,7 @@ L10:
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:
@ -131,7 +130,7 @@ L30:
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:
@ -146,7 +145,7 @@ L50:
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:
@ -177,7 +176,7 @@ L80:
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:
@ -191,7 +190,7 @@ L100:
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:
@ -207,9 +206,8 @@ L120:
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_ */

148
blas/f2c/drotmg.c
View File

@ -12,9 +12,7 @@
#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.;
@ -41,73 +39,72 @@
/* 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 .. */
/* .. */
/* .. Local Scalars .. */ /* .. Intrinsic Functions .. */
/* .. */ /* .. */
/* .. Intrinsic Functions .. */ /* .. Data statements .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */ /* Parameter adjustments */
--dparam; --dparam;
/* Function Body */ /* Function Body */
/* .. */ /* .. */
if (! (*dd1 < zero)) { if (!(*dd1 < zero)) {
goto L10; goto L10;
} }
/* GO ZERO-H-D-AND-DX1.. */ /* GO ZERO-H-D-AND-DX1.. */
goto L60; 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;
@ -118,7 +115,7 @@ L20:
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;
@ -126,23 +123,23 @@ L20:
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;
@ -153,7 +150,7 @@ L50:
*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:
@ -166,15 +163,15 @@ L60:
*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; goto L90;
} }
if (! (dflag == zero)) { if (!(dflag == zero)) {
goto L80; goto L80;
} }
dh11 = one; dh11 = one;
@ -187,15 +184,19 @@ L80:
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) {
@ -203,10 +204,10 @@ L110:
} }
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;
@ -215,15 +216,15 @@ L120:
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;
@ -232,7 +233,7 @@ L150:
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) {
@ -240,10 +241,10 @@ L170:
} }
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;
@ -251,15 +252,15 @@ L180:
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;
@ -290,4 +291,3 @@ L260:
dparam[1] = dflag; dparam[1] = dflag;
return 0; return 0;
} /* drotmg_ */ } /* drotmg_ */

291
blas/f2c/dsbmv.c
View File

@ -12,10 +12,9 @@
#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;
@ -26,144 +25,143 @@
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 */ /* Parameter adjustments */
a_dim1 = *lda; a_dim1 = *lda;
@ -174,8 +172,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -193,13 +190,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) { if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -212,10 +209,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array A */ /* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */ /* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (*beta != 1.) { if (*beta != 1.) {
if (*incy == 1) { if (*incy == 1) {
@ -223,13 +220,13 @@
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.; y[i__] = 0.;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__]; y[i__] = *beta * y[i__];
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -239,14 +236,14 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.; y[iy] = 0.;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy]; y[iy] = *beta * y[iy];
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -255,8 +252,7 @@
return 0; return 0;
} }
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1; kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
@ -265,16 +261,16 @@
temp1 = *alpha * x[j]; temp1 = *alpha * x[j];
temp2 = 0.; temp2 = 0.;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1]; y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__]; temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L50: */ /* L50: */
} }
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -286,30 +282,28 @@
ix = kx; ix = kx;
iy = ky; iy = ky;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
y[iy] += temp1 * a[l + i__ + j * a_dim1]; y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix]; temp2 += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
if (j > *k) { if (j > *k) {
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
} }
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when lower triangle of A is stored. */
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
@ -318,16 +312,16 @@
temp2 = 0.; temp2 = 0.;
y[j] += temp1 * a[j * a_dim1 + 1]; y[j] += temp1 * a[j * a_dim1 + 1];
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1]; y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__]; temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */ /* L90: */
} }
y[j] += *alpha * temp2; y[j] += *alpha * temp2;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -340,27 +334,26 @@
l = 1 - j; l = 1 - j;
ix = jx; ix = jx;
iy = jy; iy = jy;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
y[iy] += temp1 * a[l + i__ + j * a_dim1]; y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix]; temp2 += a[l + i__ + j * a_dim1] * x[ix];
/* L110: */ /* L110: */
} }
y[jy] += *alpha * temp2; y[jy] += *alpha * temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of DSBMV . */ /* End of DSBMV . */
} /* dsbmv_ */ } /* dsbmv_ */

214
blas/f2c/dspmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
@ -25,110 +23,110 @@
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;
@ -137,8 +135,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -152,13 +149,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) { if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -171,10 +168,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array AP */ /* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */ /* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (*beta != 1.) { if (*beta != 1.) {
if (*incy == 1) { if (*incy == 1) {
@ -182,13 +179,13 @@
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.; y[i__] = 0.;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__]; y[i__] = *beta * y[i__];
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -198,14 +195,14 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.; y[iy] = 0.;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy]; y[iy] = *beta * y[iy];
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -215,8 +212,7 @@
} }
kk = 1; kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
@ -229,11 +225,11 @@
y[i__] += temp1 * ap[k]; y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__]; temp2 += ap[k] * x[i__];
++k; ++k;
/* L50: */ /* L50: */
} }
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
kk += j; kk += j;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -250,18 +246,17 @@
temp2 += ap[k] * x[ix]; temp2 += ap[k] * x[ix];
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += j; kk += j;
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when AP contains the lower triangle. */
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
@ -275,11 +270,11 @@
y[i__] += temp1 * ap[k]; y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__]; temp2 += ap[k] * x[i__];
++k; ++k;
/* L90: */ /* L90: */
} }
y[j] += *alpha * temp2; y[j] += *alpha * temp2;
kk += *n - j + 1; kk += *n - j + 1;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -297,20 +292,19 @@
iy += *incy; iy += *incy;
y[iy] += temp1 * ap[k]; y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix]; temp2 += ap[k] * x[ix];
/* L110: */ /* L110: */
} }
y[jy] += *alpha * temp2; y[jy] += *alpha * temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += *n - j + 1; kk += *n - j + 1;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of DSPMV . */ /* End of DSPMV . */
} /* dspmv_ */ } /* dspmv_ */

328
blas/f2c/dtbmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* 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;
@ -27,154 +25,154 @@
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;
@ -184,15 +182,12 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, } else if (!lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && !lsame_(trans, "T", (ftnlen)1, (ftnlen)1) &&
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( !lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
ftnlen)1)) {
info = 2; info = 2;
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, } else if (!lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && !lsame_(diag, "N", (ftnlen)1, (ftnlen)1)) {
"N", (ftnlen)1, (ftnlen)1)) {
info = 3; info = 3;
} else if (*n < 0) { } else if (*n < 0) {
info = 4; info = 4;
@ -208,7 +203,7 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
@ -216,8 +211,8 @@
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* Set up the start point in X if the increment is not unity. This */ /* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */ /* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 0) { if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx; kx = 1 - (*n - 1) * *incx;
@ -225,12 +220,11 @@
kx = 1; kx = 1;
} }
/* Start the operations. In this version the elements of A are */ /* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */ /* accessed sequentially with one pass through A. */
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -240,18 +234,18 @@
if (x[j] != 0.) { if (x[j] != 0.) {
temp = x[j]; temp = x[j];
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
x[i__] += temp * a[l + i__ + j * a_dim1]; x[i__] += temp * a[l + i__ + j * a_dim1];
/* L10: */ /* L10: */
} }
if (nounit) { if (nounit) {
x[j] *= a[kplus1 + j * a_dim1]; x[j] *= a[kplus1 + j * a_dim1];
} }
} }
/* L20: */ /* L20: */
} }
} else { } else {
jx = kx; jx = kx;
@ -261,13 +255,13 @@
temp = x[jx]; temp = x[jx];
ix = kx; ix = kx;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
x[ix] += temp * a[l + i__ + j * a_dim1]; x[ix] += temp * a[l + i__ + j * a_dim1];
ix += *incx; ix += *incx;
/* L30: */ /* L30: */
} }
if (nounit) { if (nounit) {
x[jx] *= a[kplus1 + j * a_dim1]; x[jx] *= a[kplus1 + j * a_dim1];
@ -277,7 +271,7 @@
if (j > *k) { if (j > *k) {
kx += *incx; kx += *incx;
} }
/* L40: */ /* L40: */
} }
} }
} else { } else {
@ -286,18 +280,18 @@
if (x[j] != 0.) { if (x[j] != 0.) {
temp = x[j]; temp = x[j];
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__3 = j + *k; i__1 = *n, i__3 = j + *k;
i__4 = j + 1; i__4 = j + 1;
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { for (i__ = min(i__1, i__3); i__ >= i__4; --i__) {
x[i__] += temp * a[l + i__ + j * a_dim1]; x[i__] += temp * a[l + i__ + j * a_dim1];
/* L50: */ /* L50: */
} }
if (nounit) { if (nounit) {
x[j] *= a[j * a_dim1 + 1]; x[j] *= a[j * a_dim1 + 1];
} }
} }
/* L60: */ /* L60: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -307,13 +301,13 @@
temp = x[jx]; temp = x[jx];
ix = kx; ix = kx;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__1 = j + *k; i__4 = *n, i__1 = j + *k;
i__3 = j + 1; i__3 = j + 1;
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { for (i__ = min(i__4, i__1); i__ >= i__3; --i__) {
x[ix] += temp * a[l + i__ + j * a_dim1]; x[ix] += temp * a[l + i__ + j * a_dim1];
ix -= *incx; ix -= *incx;
/* L70: */ /* L70: */
} }
if (nounit) { if (nounit) {
x[jx] *= a[j * a_dim1 + 1]; x[jx] *= a[j * a_dim1 + 1];
@ -323,13 +317,12 @@
if (*n - j >= *k) { if (*n - j >= *k) {
kx -= *incx; kx -= *incx;
} }
/* L80: */ /* L80: */
} }
} }
} }
} else { } else {
/* Form x := A'*x. */
/* Form x := A'*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -340,15 +333,15 @@
if (nounit) { if (nounit) {
temp *= a[kplus1 + j * a_dim1]; temp *= a[kplus1 + j * a_dim1];
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[i__]; temp += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */ /* L90: */
} }
x[j] = temp; x[j] = temp;
/* L100: */ /* L100: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -361,17 +354,17 @@
if (nounit) { if (nounit) {
temp *= a[kplus1 + j * a_dim1]; temp *= a[kplus1 + j * a_dim1];
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[ix]; temp += a[l + i__ + j * a_dim1] * x[ix];
ix -= *incx; ix -= *incx;
/* L110: */ /* L110: */
} }
x[jx] = temp; x[jx] = temp;
jx -= *incx; jx -= *incx;
/* L120: */ /* L120: */
} }
} }
} else { } else {
@ -383,15 +376,15 @@
if (nounit) { if (nounit) {
temp *= a[j * a_dim1 + 1]; temp *= a[j * a_dim1 + 1];
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[i__]; temp += a[l + i__ + j * a_dim1] * x[i__];
/* L130: */ /* L130: */
} }
x[j] = temp; x[j] = temp;
/* L140: */ /* L140: */
} }
} else { } else {
jx = kx; jx = kx;
@ -404,17 +397,17 @@
if (nounit) { if (nounit) {
temp *= a[j * a_dim1 + 1]; temp *= a[j * a_dim1 + 1];
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[ix]; temp += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx; ix += *incx;
/* L150: */ /* L150: */
} }
x[jx] = temp; x[jx] = temp;
jx += *incx; jx += *incx;
/* L160: */ /* L160: */
} }
} }
} }
@ -422,7 +415,6 @@
return 0; return 0;
/* End of DTBMV . */ /* End of DTBMV . */
} /* dtbmv_ */ } /* dtbmv_ */

80
blas/f2c/lsame.c
View File

@ -12,66 +12,63 @@
#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; ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
if (ret_val) { if (ret_val) {
return ret_val; return ret_val;
} }
/* Now test for equivalence if both characters are alphabetic. */ /* Now test for equivalence if both characters are alphabetic. */
zcode = 'Z'; zcode = 'Z';
/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */ /* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
/* machines, on which ICHAR returns a value with bit 8 set. */ /* 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 Prime machines returns 193 which is the same as */
/* ICHAR('A') on an EBCDIC machine. */ /* ICHAR('A') on an EBCDIC machine. */
inta = *(unsigned char *)ca; inta = *(unsigned char *)ca;
intb = *(unsigned char *)cb; intb = *(unsigned char *)cb;
if (zcode == 90 || zcode == 122) { if (zcode == 90 || zcode == 122) {
/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
/* ASCII is assumed - ZCODE is the ASCII code of either lower or */ /* upper case 'Z'. */
/* upper case 'Z'. */
if (inta >= 97 && inta <= 122) { if (inta >= 97 && inta <= 122) {
inta += -32; inta += -32;
@ -81,23 +78,19 @@ logical lsame_(char *ca, char *cb, ftnlen ca_len, ftnlen cb_len)
} }
} else if (zcode == 233 || zcode == 169) { } else if (zcode == 233 || zcode == 169) {
/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
/* upper case 'Z'. */
/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */ if ((inta >= 129 && inta <= 137) || (inta >= 145 && inta <= 153) || (inta >= 162 && inta <= 169)) {
/* upper case 'Z'. */
if ((inta >= 129 && inta <= 137) || (inta >= 145 && inta <= 153) ||
(inta >= 162 && inta <= 169)) {
inta += 64; inta += 64;
} }
if ((intb >= 129 && intb <= 137) || (intb >= 145 && intb <= 153) || if ((intb >= 129 && intb <= 137) || (intb >= 145 && intb <= 153) || (intb >= 162 && intb <= 169)) {
(intb >= 162 && intb <= 169)) {
intb += 64; intb += 64;
} }
} else if (zcode == 218 || zcode == 250) { } else if (zcode == 218 || zcode == 250) {
/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */ /* plus 128 of either lower or upper case 'Z'. */
/* plus 128 of either lower or upper case 'Z'. */
if (inta >= 225 && inta <= 250) { if (inta >= 225 && inta <= 250) {
inta += -32; inta += -32;
@ -108,10 +101,9 @@ logical lsame_(char *ca, char *cb, ftnlen ca_len, ftnlen cb_len)
} }
ret_val = inta == intb; ret_val = inta == intb;
/* RETURN */ /* RETURN */
/* End of LSAME */ /* End of LSAME */
return ret_val; return ret_val;
} /* lsame_ */ } /* lsame_ */

100
blas/f2c/srotm.c
View File

@ -12,9 +12,7 @@
#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;
@ -30,74 +28,73 @@
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 .. */
/* .. */
/* .. Local Scalars .. */ /* .. Data statements .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */ /* Parameter adjustments */
--sparam; --sparam;
--sy; --sy;
--sx; --sx;
/* Function Body */ /* Function Body */
/* .. */ /* .. */
sflag = sparam[1]; sflag = sparam[1];
if (*n <= 0 || sflag + two == zero) { if (*n <= 0 || sflag + two == zero) {
goto L140; goto L140;
} }
if (! (*incx == *incy && *incx > 0)) { if (!(*incx == *incy && *incx > 0)) {
goto L70; goto L70;
} }
@ -119,7 +116,7 @@ L10:
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:
@ -132,7 +129,7 @@ L30:
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:
@ -147,7 +144,7 @@ L50:
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:
@ -178,7 +175,7 @@ L80:
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:
@ -192,7 +189,7 @@ L100:
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:
@ -208,9 +205,8 @@ L120:
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_ */

150
blas/f2c/srotmg.c
View File

@ -12,9 +12,7 @@
#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;
@ -41,75 +39,72 @@
/* 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 .. */
/* SPARAM (input/output) REAL array, dimension 5 */ /* .. */
/* SPARAM(1)=SFLAG */ /* .. Intrinsic Functions .. */
/* SPARAM(2)=SH11 */ /* .. */
/* SPARAM(3)=SH21 */ /* .. Data statements .. */
/* SPARAM(4)=SH12 */
/* SPARAM(5)=SH22 */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */ /* Parameter adjustments */
--sparam; --sparam;
/* Function Body */ /* Function Body */
/* .. */ /* .. */
if (! (*sd1 < zero)) { if (!(*sd1 < zero)) {
goto L10; goto L10;
} }
/* GO ZERO-H-D-AND-SX1.. */ /* GO ZERO-H-D-AND-SX1.. */
goto L60; 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;
@ -120,7 +115,7 @@ L20:
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;
@ -128,23 +123,23 @@ L20:
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;
@ -155,7 +150,7 @@ L50:
*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:
@ -168,15 +163,15 @@ L60:
*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; goto L90;
} }
if (! (sflag == zero)) { if (!(sflag == zero)) {
goto L80; goto L80;
} }
sh11 = one; sh11 = one;
@ -189,15 +184,19 @@ L80:
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) {
@ -205,10 +204,10 @@ L110:
} }
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;
@ -217,15 +216,15 @@ L120:
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;
@ -234,7 +233,7 @@ L150:
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) {
@ -242,10 +241,10 @@ L170:
} }
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;
@ -253,15 +252,15 @@ L180:
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;
@ -292,4 +291,3 @@ L260:
sparam[1] = sflag; sparam[1] = sflag;
return 0; return 0;
} /* srotmg_ */ } /* srotmg_ */

293
blas/f2c/ssbmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* 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;
@ -26,146 +24,146 @@
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;
@ -176,8 +174,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -195,13 +192,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) { if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -214,10 +211,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array A */ /* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */ /* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (*beta != 1.f) { if (*beta != 1.f) {
if (*incy == 1) { if (*incy == 1) {
@ -225,13 +222,13 @@
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.f; y[i__] = 0.f;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__]; y[i__] = *beta * y[i__];
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -241,14 +238,14 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.f; y[iy] = 0.f;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy]; y[iy] = *beta * y[iy];
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -257,8 +254,7 @@
return 0; return 0;
} }
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1; kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
@ -267,16 +263,16 @@
temp1 = *alpha * x[j]; temp1 = *alpha * x[j];
temp2 = 0.f; temp2 = 0.f;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1]; y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__]; temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L50: */ /* L50: */
} }
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -288,30 +284,28 @@
ix = kx; ix = kx;
iy = ky; iy = ky;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
y[iy] += temp1 * a[l + i__ + j * a_dim1]; y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix]; temp2 += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
if (j > *k) { if (j > *k) {
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
} }
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when lower triangle of A is stored. */
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
@ -320,16 +314,16 @@
temp2 = 0.f; temp2 = 0.f;
y[j] += temp1 * a[j * a_dim1 + 1]; y[j] += temp1 * a[j * a_dim1 + 1];
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
y[i__] += temp1 * a[l + i__ + j * a_dim1]; y[i__] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[i__]; temp2 += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */ /* L90: */
} }
y[j] += *alpha * temp2; y[j] += *alpha * temp2;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -342,27 +336,26 @@
l = 1 - j; l = 1 - j;
ix = jx; ix = jx;
iy = jy; iy = jy;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
y[iy] += temp1 * a[l + i__ + j * a_dim1]; y[iy] += temp1 * a[l + i__ + j * a_dim1];
temp2 += a[l + i__ + j * a_dim1] * x[ix]; temp2 += a[l + i__ + j * a_dim1] * x[ix];
/* L110: */ /* L110: */
} }
y[jy] += *alpha * temp2; y[jy] += *alpha * temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of SSBMV . */ /* End of SSBMV . */
} /* ssbmv_ */ } /* ssbmv_ */

214
blas/f2c/sspmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* System generated locals */
integer i__1, i__2; integer i__1, i__2;
@ -25,110 +23,110 @@
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;
@ -137,8 +135,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -152,13 +149,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) { if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -171,10 +168,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array AP */ /* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */ /* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (*beta != 1.f) { if (*beta != 1.f) {
if (*incy == 1) { if (*incy == 1) {
@ -182,13 +179,13 @@
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.f; y[i__] = 0.f;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__]; y[i__] = *beta * y[i__];
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -198,14 +195,14 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.f; y[iy] = 0.f;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy]; y[iy] = *beta * y[iy];
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -215,8 +212,7 @@
} }
kk = 1; kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
@ -229,11 +225,11 @@
y[i__] += temp1 * ap[k]; y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__]; temp2 += ap[k] * x[i__];
++k; ++k;
/* L50: */ /* L50: */
} }
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
kk += j; kk += j;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -250,18 +246,17 @@
temp2 += ap[k] * x[ix]; temp2 += ap[k] * x[ix];
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += j; kk += j;
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when AP contains the lower triangle. */
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
@ -275,11 +270,11 @@
y[i__] += temp1 * ap[k]; y[i__] += temp1 * ap[k];
temp2 += ap[k] * x[i__]; temp2 += ap[k] * x[i__];
++k; ++k;
/* L90: */ /* L90: */
} }
y[j] += *alpha * temp2; y[j] += *alpha * temp2;
kk += *n - j + 1; kk += *n - j + 1;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -297,20 +292,19 @@
iy += *incy; iy += *incy;
y[iy] += temp1 * ap[k]; y[iy] += temp1 * ap[k];
temp2 += ap[k] * x[ix]; temp2 += ap[k] * x[ix];
/* L110: */ /* L110: */
} }
y[jy] += *alpha * temp2; y[jy] += *alpha * temp2;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += *n - j + 1; kk += *n - j + 1;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of SSPMV . */ /* End of SSPMV . */
} /* sspmv_ */ } /* sspmv_ */

328
blas/f2c/stbmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* 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;
@ -27,154 +25,154 @@
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;
@ -184,15 +182,12 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, } else if (!lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && !lsame_(trans, "T", (ftnlen)1, (ftnlen)1) &&
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( !lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
ftnlen)1)) {
info = 2; info = 2;
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, } else if (!lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && !lsame_(diag, "N", (ftnlen)1, (ftnlen)1)) {
"N", (ftnlen)1, (ftnlen)1)) {
info = 3; info = 3;
} else if (*n < 0) { } else if (*n < 0) {
info = 4; info = 4;
@ -208,7 +203,7 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
@ -216,8 +211,8 @@
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* Set up the start point in X if the increment is not unity. This */ /* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */ /* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 0) { if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx; kx = 1 - (*n - 1) * *incx;
@ -225,12 +220,11 @@
kx = 1; kx = 1;
} }
/* Start the operations. In this version the elements of A are */ /* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */ /* accessed sequentially with one pass through A. */
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -240,18 +234,18 @@
if (x[j] != 0.f) { if (x[j] != 0.f) {
temp = x[j]; temp = x[j];
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
x[i__] += temp * a[l + i__ + j * a_dim1]; x[i__] += temp * a[l + i__ + j * a_dim1];
/* L10: */ /* L10: */
} }
if (nounit) { if (nounit) {
x[j] *= a[kplus1 + j * a_dim1]; x[j] *= a[kplus1 + j * a_dim1];
} }
} }
/* L20: */ /* L20: */
} }
} else { } else {
jx = kx; jx = kx;
@ -261,13 +255,13 @@
temp = x[jx]; temp = x[jx];
ix = kx; ix = kx;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
x[ix] += temp * a[l + i__ + j * a_dim1]; x[ix] += temp * a[l + i__ + j * a_dim1];
ix += *incx; ix += *incx;
/* L30: */ /* L30: */
} }
if (nounit) { if (nounit) {
x[jx] *= a[kplus1 + j * a_dim1]; x[jx] *= a[kplus1 + j * a_dim1];
@ -277,7 +271,7 @@
if (j > *k) { if (j > *k) {
kx += *incx; kx += *incx;
} }
/* L40: */ /* L40: */
} }
} }
} else { } else {
@ -286,18 +280,18 @@
if (x[j] != 0.f) { if (x[j] != 0.f) {
temp = x[j]; temp = x[j];
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__3 = j + *k; i__1 = *n, i__3 = j + *k;
i__4 = j + 1; i__4 = j + 1;
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { for (i__ = min(i__1, i__3); i__ >= i__4; --i__) {
x[i__] += temp * a[l + i__ + j * a_dim1]; x[i__] += temp * a[l + i__ + j * a_dim1];
/* L50: */ /* L50: */
} }
if (nounit) { if (nounit) {
x[j] *= a[j * a_dim1 + 1]; x[j] *= a[j * a_dim1 + 1];
} }
} }
/* L60: */ /* L60: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -307,13 +301,13 @@
temp = x[jx]; temp = x[jx];
ix = kx; ix = kx;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__1 = j + *k; i__4 = *n, i__1 = j + *k;
i__3 = j + 1; i__3 = j + 1;
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { for (i__ = min(i__4, i__1); i__ >= i__3; --i__) {
x[ix] += temp * a[l + i__ + j * a_dim1]; x[ix] += temp * a[l + i__ + j * a_dim1];
ix -= *incx; ix -= *incx;
/* L70: */ /* L70: */
} }
if (nounit) { if (nounit) {
x[jx] *= a[j * a_dim1 + 1]; x[jx] *= a[j * a_dim1 + 1];
@ -323,13 +317,12 @@
if (*n - j >= *k) { if (*n - j >= *k) {
kx -= *incx; kx -= *incx;
} }
/* L80: */ /* L80: */
} }
} }
} }
} else { } else {
/* Form x := A'*x. */
/* Form x := A'*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -340,15 +333,15 @@
if (nounit) { if (nounit) {
temp *= a[kplus1 + j * a_dim1]; temp *= a[kplus1 + j * a_dim1];
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[i__]; temp += a[l + i__ + j * a_dim1] * x[i__];
/* L90: */ /* L90: */
} }
x[j] = temp; x[j] = temp;
/* L100: */ /* L100: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -361,17 +354,17 @@
if (nounit) { if (nounit) {
temp *= a[kplus1 + j * a_dim1]; temp *= a[kplus1 + j * a_dim1];
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
temp += a[l + i__ + j * a_dim1] * x[ix]; temp += a[l + i__ + j * a_dim1] * x[ix];
ix -= *incx; ix -= *incx;
/* L110: */ /* L110: */
} }
x[jx] = temp; x[jx] = temp;
jx -= *incx; jx -= *incx;
/* L120: */ /* L120: */
} }
} }
} else { } else {
@ -383,15 +376,15 @@
if (nounit) { if (nounit) {
temp *= a[j * a_dim1 + 1]; temp *= a[j * a_dim1 + 1];
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[i__]; temp += a[l + i__ + j * a_dim1] * x[i__];
/* L130: */ /* L130: */
} }
x[j] = temp; x[j] = temp;
/* L140: */ /* L140: */
} }
} else { } else {
jx = kx; jx = kx;
@ -404,17 +397,17 @@
if (nounit) { if (nounit) {
temp *= a[j * a_dim1 + 1]; temp *= a[j * a_dim1 + 1];
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
temp += a[l + i__ + j * a_dim1] * x[ix]; temp += a[l + i__ + j * a_dim1] * x[ix];
ix += *incx; ix += *incx;
/* L150: */ /* L150: */
} }
x[jx] = temp; x[jx] = temp;
jx += *incx; jx += *incx;
/* L160: */ /* L160: */
} }
} }
} }
@ -422,7 +415,6 @@
return 0; return 0;
/* End of STBMV . */ /* End of STBMV . */
} /* stbmv_ */ } /* stbmv_ */

359
blas/f2c/zhbmv.c
View File

@ -12,11 +12,9 @@
#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 */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1; doublereal d__1;
@ -32,148 +30,148 @@
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;
@ -184,8 +182,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -203,14 +200,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.))) {
beta->i == 0.))) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -223,10 +219,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array A */ /* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */ /* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.) { if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) { if (*incy == 1) {
@ -235,18 +231,16 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.; y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -257,19 +251,17 @@
i__2 = iy; i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.; y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy; i__2 = iy;
i__3 = iy; i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -278,38 +270,33 @@
return 0; return 0;
} }
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1; kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j; i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__2 = i__; i__2 = i__;
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, z__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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
/* L50: */ /* L50: */
} }
i__4 = j; i__4 = j;
i__2 = j; i__2 = j;
@ -317,11 +304,10 @@
d__1 = a[i__3].r; d__1 = a[i__3].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; 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__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 = z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__4].r = z__1.r, y[i__4].i = z__1.i;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -329,34 +315,30 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__4 = jx; i__4 = jx;
z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i = 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;
alpha->r * x[i__4].i + alpha->i * x[i__4].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
ix = kx; ix = kx;
iy = ky; iy = ky;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
i__4 = iy; i__4 = iy;
i__2 = iy; i__2 = iy;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = ix; i__4 = ix;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
i__3 = jy; i__3 = jy;
i__4 = jy; i__4 = jy;
@ -364,8 +346,7 @@
d__1 = a[i__2].r; d__1 = a[i__2].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; 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__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 = z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
jx += *incx; jx += *incx;
@ -374,19 +355,17 @@
kx += *incx; kx += *incx;
ky += *incy; ky += *incy;
} }
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when lower triangle of A is stored. */
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__3 = j; i__3 = j;
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = 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;
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
i__3 = j; i__3 = j;
@ -397,33 +376,29 @@
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__; i__4 = i__;
i__2 = i__; i__2 = i__;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = i__; i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
/* L90: */ /* L90: */
} }
i__3 = j; i__3 = j;
i__4 = j; i__4 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -431,8 +406,7 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__3 = jx; i__3 = jx;
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = 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;
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
i__3 = jy; i__3 = jy;
@ -445,44 +419,39 @@
l = 1 - j; l = 1 - j;
ix = jx; ix = jx;
iy = jy; iy = jy;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__2 = j + *k; i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2); i__3 = min(i__4, i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) { for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
i__4 = iy; i__4 = iy;
i__2 = iy; i__2 = iy;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, 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__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; 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; y[i__4].r = z__1.r, y[i__4].i = z__1.i;
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = ix; i__4 = ix;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
/* L110: */ /* L110: */
} }
i__3 = jy; i__3 = jy;
i__4 = jy; i__4 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of ZHBMV . */ /* End of ZHBMV . */
} /* zhbmv_ */ } /* zhbmv_ */

285
blas/f2c/zhpmv.c
View File

@ -12,10 +12,8 @@
#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 */ /* System generated locals */
integer i__1, i__2, i__3, i__4, i__5; integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1; doublereal d__1;
@ -30,114 +28,114 @@
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;
@ -146,8 +144,7 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (*n < 0) { } else if (*n < 0) {
info = 2; info = 2;
@ -161,14 +158,13 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.))) {
beta->i == 0.))) {
return 0; return 0;
} }
/* Set up the start points in X and Y. */ /* Set up the start points in X and Y. */
if (*incx > 0) { if (*incx > 0) {
kx = 1; kx = 1;
@ -181,10 +177,10 @@
ky = 1 - (*n - 1) * *incy; ky = 1 - (*n - 1) * *incy;
} }
/* Start the operations. In this version the elements of the array AP */ /* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */ /* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */ /* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.) { if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) { if (*incy == 1) {
@ -193,18 +189,16 @@
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.; y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */ /* L10: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */ /* L20: */
} }
} }
} else { } else {
@ -215,19 +209,17 @@
i__2 = iy; i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.; y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy; iy += *incy;
/* L30: */ /* L30: */
} }
} else { } else {
i__1 = *n; i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) { for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy; i__2 = iy;
i__3 = iy; i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[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;
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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy; iy += *incy;
/* L40: */ /* L40: */
} }
} }
} }
@ -237,15 +229,13 @@
} }
kk = 1; kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when AP contains the upper triangle. */
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j; i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
k = kk; k = kk;
@ -254,19 +244,16 @@
i__3 = i__; i__3 = i__;
i__4 = i__; i__4 = i__;
i__5 = k; i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]); d_cnjg(&z__3, &ap[k]);
i__3 = i__; i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
++k; ++k;
/* L50: */ /* L50: */
} }
i__2 = j; i__2 = j;
i__3 = j; i__3 = j;
@ -274,12 +261,11 @@
d__1 = ap[i__4].r; d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; 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__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 = z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += j; kk += j;
/* L60: */ /* L60: */
} }
} else { } else {
jx = kx; jx = kx;
@ -287,8 +273,7 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = jx; i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
ix = kx; ix = kx;
@ -298,20 +283,17 @@
i__3 = iy; i__3 = iy;
i__4 = iy; i__4 = iy;
i__5 = k; i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]); d_cnjg(&z__3, &ap[k]);
i__3 = ix; i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx; ix += *incx;
iy += *incy; iy += *incy;
/* L70: */ /* L70: */
} }
i__2 = jy; i__2 = jy;
i__3 = jy; i__3 = jy;
@ -319,26 +301,23 @@
d__1 = ap[i__4].r; d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; 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__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 = z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += j; kk += j;
/* L80: */ /* L80: */
} }
} }
} else { } else {
/* Form y when AP contains the lower triangle. */
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1) { if (*incx == 1 && *incy == 1) {
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = j; i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
i__2 = j; i__2 = j;
@ -354,28 +333,24 @@
i__3 = i__; i__3 = i__;
i__4 = i__; i__4 = i__;
i__5 = k; i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]); d_cnjg(&z__3, &ap[k]);
i__3 = i__; i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
++k; ++k;
/* L90: */ /* L90: */
} }
i__2 = j; i__2 = j;
i__3 = j; i__3 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += *n - j + 1; kk += *n - j + 1;
/* L100: */ /* L100: */
} }
} else { } else {
jx = kx; jx = kx;
@ -383,8 +358,7 @@
i__1 = *n; i__1 = *n;
for (j = 1; j <= i__1; ++j) { for (j = 1; j <= i__1; ++j) {
i__2 = jx; i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = 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;
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i; temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.; temp2.r = 0., temp2.i = 0.;
i__2 = jy; i__2 = jy;
@ -403,36 +377,31 @@
i__3 = iy; i__3 = iy;
i__4 = iy; i__4 = iy;
i__5 = k; i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, 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__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; 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; y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]); d_cnjg(&z__3, &ap[k]);
i__3 = ix; i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.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__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; 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; temp2.r = z__1.r, temp2.i = z__1.i;
/* L110: */ /* L110: */
} }
i__2 = jy; i__2 = jy;
i__3 = jy; i__3 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
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; 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; y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx; jx += *incx;
jy += *incy; jy += *incy;
kk += *n - j + 1; kk += *n - j + 1;
/* L120: */ /* L120: */
} }
} }
} }
return 0; return 0;
/* End of ZHPMV . */ /* End of ZHPMV . */
} /* zhpmv_ */ } /* zhpmv_ */

492
blas/f2c/ztbmv.c
View File

@ -12,10 +12,8 @@
#include "datatypes.h" #include "datatypes.h"
/* Subroutine */ int ztbmv_(char *uplo, char *trans, char *diag, integer *n, /* Subroutine */ int ztbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, doublecomplex *a, integer *lda,
integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer doublecomplex *x, integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) {
*incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
{
/* System generated locals */ /* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3; doublecomplex z__1, z__2, z__3;
@ -31,154 +29,154 @@
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical noconj, nounit; logical noconj, nounit;
/* .. Scalar Arguments .. */ /* .. Scalar Arguments .. */
/* .. */ /* .. */
/* .. Array Arguments .. */ /* .. Array Arguments .. */
/* .. */ /* .. */
/* Purpose */ /* Purpose */
/* ======= */ /* ======= */
/* ZTBMV performs one of the matrix-vector operations */ /* ZTBMV performs one of the matrix-vector operations */
/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ /* x := A*x, or x := A'*x, or x := conjg( 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 := conjg( A' )*x. */ /* TRANS = 'C' or 'c' x := conjg( 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 - 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 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 - 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. 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;
@ -188,15 +186,12 @@
/* Function Body */ /* Function Body */
info = 0; info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( if (!lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
ftnlen)1, (ftnlen)1)) {
info = 1; info = 1;
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, } else if (!lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && !lsame_(trans, "T", (ftnlen)1, (ftnlen)1) &&
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( !lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
ftnlen)1)) {
info = 2; info = 2;
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, } else if (!lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && !lsame_(diag, "N", (ftnlen)1, (ftnlen)1)) {
"N", (ftnlen)1, (ftnlen)1)) {
info = 3; info = 3;
} else if (*n < 0) { } else if (*n < 0) {
info = 4; info = 4;
@ -212,7 +207,7 @@
return 0; return 0;
} }
/* Quick return if possible. */ /* Quick return if possible. */
if (*n == 0) { if (*n == 0) {
return 0; return 0;
@ -221,8 +216,8 @@
noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1); noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* Set up the start point in X if the increment is not unity. This */ /* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */ /* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 0) { if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx; kx = 1 - (*n - 1) * *incx;
@ -230,12 +225,11 @@
kx = 1; kx = 1;
} }
/* Start the operations. In this version the elements of A are */ /* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */ /* accessed sequentially with one pass through A. */
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
/* Form x := A*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -247,32 +241,28 @@
i__2 = j; i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i; temp.r = x[i__2].r, temp.i = x[i__2].i;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__2 = 1, i__3 = j - *k; i__2 = 1, i__3 = j - *k;
i__4 = j - 1; i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { for (i__ = max(i__2, i__3); i__ <= i__4; ++i__) {
i__2 = i__; i__2 = i__;
i__3 = i__; i__3 = i__;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r;
z__2.i = temp.r * a[i__5].i + temp.i * a[ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + z__2.i;
i__5].r;
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
z__2.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i; x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/* L10: */ /* L10: */
} }
if (nounit) { if (nounit) {
i__4 = j; i__4 = j;
i__2 = j; i__2 = j;
i__3 = kplus1 + j * a_dim1; i__3 = kplus1 + j * a_dim1;
z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[i__3].i,
i__3].i, z__1.i = x[i__2].r * a[i__3].i + z__1.i = x[i__2].r * a[i__3].i + x[i__2].i * a[i__3].r;
x[i__2].i * a[i__3].r;
x[i__4].r = z__1.r, x[i__4].i = z__1.i; x[i__4].r = z__1.r, x[i__4].i = z__1.i;
} }
} }
/* L20: */ /* L20: */
} }
} else { } else {
jx = kx; jx = kx;
@ -284,29 +274,25 @@
temp.r = x[i__4].r, temp.i = x[i__4].i; temp.r = x[i__4].r, temp.i = x[i__4].i;
ix = kx; ix = kx;
l = kplus1 - j; l = kplus1 - j;
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__2 = j - *k; i__4 = 1, i__2 = j - *k;
i__3 = j - 1; i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { for (i__ = max(i__4, i__2); i__ <= i__3; ++i__) {
i__4 = ix; i__4 = ix;
i__2 = ix; i__2 = ix;
i__5 = l + i__ + j * a_dim1; i__5 = l + i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r;
z__2.i = temp.r * a[i__5].i + temp.i * a[ z__1.r = x[i__2].r + z__2.r, z__1.i = x[i__2].i + z__2.i;
i__5].r;
z__1.r = x[i__2].r + z__2.r, z__1.i = x[i__2].i +
z__2.i;
x[i__4].r = z__1.r, x[i__4].i = z__1.i; x[i__4].r = z__1.r, x[i__4].i = z__1.i;
ix += *incx; ix += *incx;
/* L30: */ /* L30: */
} }
if (nounit) { if (nounit) {
i__3 = jx; i__3 = jx;
i__4 = jx; i__4 = jx;
i__2 = kplus1 + j * a_dim1; i__2 = kplus1 + j * a_dim1;
z__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[ z__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[i__2].i,
i__2].i, z__1.i = x[i__4].r * a[i__2].i + z__1.i = x[i__4].r * a[i__2].i + x[i__4].i * a[i__2].r;
x[i__4].i * a[i__2].r;
x[i__3].r = z__1.r, x[i__3].i = z__1.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} }
} }
@ -314,7 +300,7 @@
if (j > *k) { if (j > *k) {
kx += *incx; kx += *incx;
} }
/* L40: */ /* L40: */
} }
} }
} else { } else {
@ -325,32 +311,28 @@
i__1 = j; i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i; temp.r = x[i__1].r, temp.i = x[i__1].i;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__3 = j + *k; i__1 = *n, i__3 = j + *k;
i__4 = j + 1; i__4 = j + 1;
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { for (i__ = min(i__1, i__3); i__ >= i__4; --i__) {
i__1 = i__; i__1 = i__;
i__3 = i__; i__3 = i__;
i__2 = l + i__ + j * a_dim1; i__2 = l + i__ + j * a_dim1;
z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, z__2.i = temp.r * a[i__2].i + temp.i * a[i__2].r;
z__2.i = temp.r * a[i__2].i + temp.i * a[ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + z__2.i;
i__2].r;
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
z__2.i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i; x[i__1].r = z__1.r, x[i__1].i = z__1.i;
/* L50: */ /* L50: */
} }
if (nounit) { if (nounit) {
i__4 = j; i__4 = j;
i__1 = j; i__1 = j;
i__3 = j * a_dim1 + 1; i__3 = j * a_dim1 + 1;
z__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[ z__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[i__3].i,
i__3].i, z__1.i = x[i__1].r * a[i__3].i + z__1.i = x[i__1].r * a[i__3].i + x[i__1].i * a[i__3].r;
x[i__1].i * a[i__3].r;
x[i__4].r = z__1.r, x[i__4].i = z__1.i; x[i__4].r = z__1.r, x[i__4].i = z__1.i;
} }
} }
/* L60: */ /* L60: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -362,29 +344,25 @@
temp.r = x[i__4].r, temp.i = x[i__4].i; temp.r = x[i__4].r, temp.i = x[i__4].i;
ix = kx; ix = kx;
l = 1 - j; l = 1 - j;
/* Computing MIN */ /* Computing MIN */
i__4 = *n, i__1 = j + *k; i__4 = *n, i__1 = j + *k;
i__3 = j + 1; i__3 = j + 1;
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { for (i__ = min(i__4, i__1); i__ >= i__3; --i__) {
i__4 = ix; i__4 = ix;
i__1 = ix; i__1 = ix;
i__2 = l + i__ + j * a_dim1; i__2 = l + i__ + j * a_dim1;
z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, z__2.i = temp.r * a[i__2].i + temp.i * a[i__2].r;
z__2.i = temp.r * a[i__2].i + temp.i * a[ z__1.r = x[i__1].r + z__2.r, z__1.i = x[i__1].i + z__2.i;
i__2].r;
z__1.r = x[i__1].r + z__2.r, z__1.i = x[i__1].i +
z__2.i;
x[i__4].r = z__1.r, x[i__4].i = z__1.i; x[i__4].r = z__1.r, x[i__4].i = z__1.i;
ix -= *incx; ix -= *incx;
/* L70: */ /* L70: */
} }
if (nounit) { if (nounit) {
i__3 = jx; i__3 = jx;
i__4 = jx; i__4 = jx;
i__1 = j * a_dim1 + 1; i__1 = j * a_dim1 + 1;
z__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[ z__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[i__1].i,
i__1].i, z__1.i = x[i__4].r * a[i__1].i + z__1.i = x[i__4].r * a[i__1].i + x[i__4].i * a[i__1].r;
x[i__4].i * a[i__1].r;
x[i__3].r = z__1.r, x[i__3].i = z__1.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} }
} }
@ -392,13 +370,12 @@
if (*n - j >= *k) { if (*n - j >= *k) {
kx -= *incx; kx -= *incx;
} }
/* L80: */ /* L80: */
} }
} }
} }
} else { } else {
/* Form x := A'*x or x := conjg( A' )*x. */
/* Form x := A'*x or x := conjg( A' )*x. */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
kplus1 = *k + 1; kplus1 = *k + 1;
@ -410,51 +387,42 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__3 = kplus1 + j * a_dim1; i__3 = kplus1 + j * a_dim1;
z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, z__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r;
z__1.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
i__4 = l + i__ + j * a_dim1; i__4 = l + i__ + j * a_dim1;
i__1 = i__; i__1 = i__;
z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[i__1].i,
i__1].i, z__2.i = a[i__4].r * x[i__1].i + z__2.i = a[i__4].r * x[i__1].i + a[i__4].i * x[i__1].r;
a[i__4].i * x[i__1].r; z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
/* L90: */ /* L90: */
} }
} else { } else {
if (nounit) { if (nounit) {
d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.i = temp.r * z__2.i + temp.i * z__2.r;
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = i__; i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[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__2.i = z__3.r * x[i__4].i + z__3.i * x[ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
/* L100: */ /* L100: */
} }
} }
i__3 = j; i__3 = j;
x[i__3].r = temp.r, x[i__3].i = temp.i; x[i__3].r = temp.r, x[i__3].i = temp.i;
/* L110: */ /* L110: */
} }
} else { } else {
kx += (*n - 1) * *incx; kx += (*n - 1) * *incx;
@ -468,54 +436,45 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__3 = kplus1 + j * a_dim1; i__3 = kplus1 + j * a_dim1;
z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, z__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r;
z__1.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
i__4 = l + i__ + j * a_dim1; i__4 = l + i__ + j * a_dim1;
i__1 = ix; i__1 = ix;
z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[i__1].i,
i__1].i, z__2.i = a[i__4].r * x[i__1].i + z__2.i = a[i__4].r * x[i__1].i + a[i__4].i * x[i__1].r;
a[i__4].i * x[i__1].r; z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
ix -= *incx; ix -= *incx;
/* L120: */ /* L120: */
} }
} else { } else {
if (nounit) { if (nounit) {
d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.i = temp.r * z__2.i + temp.i * z__2.r;
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MAX */ /* Computing MAX */
i__4 = 1, i__1 = j - *k; i__4 = 1, i__1 = j - *k;
i__3 = max(i__4,i__1); i__3 = max(i__4, i__1);
for (i__ = j - 1; i__ >= i__3; --i__) { for (i__ = j - 1; i__ >= i__3; --i__) {
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__4 = ix; i__4 = ix;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[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__2.i = z__3.r * x[i__4].i + z__3.i * x[ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
ix -= *incx; ix -= *incx;
/* L130: */ /* L130: */
} }
} }
i__3 = jx; i__3 = jx;
x[i__3].r = temp.r, x[i__3].i = temp.i; x[i__3].r = temp.r, x[i__3].i = temp.i;
jx -= *incx; jx -= *incx;
/* L140: */ /* L140: */
} }
} }
} else { } else {
@ -528,51 +487,42 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__4 = j * a_dim1 + 1; i__4 = j * a_dim1 + 1;
z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, z__1.i = temp.r * a[i__4].i + temp.i * a[i__4].r;
z__1.i = temp.r * a[i__4].i + temp.i * a[
i__4].r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
i__1 = l + i__ + j * a_dim1; i__1 = l + i__ + j * a_dim1;
i__2 = i__; i__2 = i__;
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[i__2].i,
i__2].i, z__2.i = a[i__1].r * x[i__2].i + z__2.i = a[i__1].r * x[i__2].i + a[i__1].i * x[i__2].r;
a[i__1].i * x[i__2].r; z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
/* L150: */ /* L150: */
} }
} else { } else {
if (nounit) { if (nounit) {
d_cnjg(&z__2, &a[j * a_dim1 + 1]); d_cnjg(&z__2, &a[j * a_dim1 + 1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.i = temp.r * z__2.i + temp.i * z__2.r;
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__1 = i__; i__1 = i__;
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, z__2.i = z__3.r * x[i__1].i + z__3.i * x[i__1].r;
z__2.i = z__3.r * x[i__1].i + z__3.i * x[ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
i__1].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
/* L160: */ /* L160: */
} }
} }
i__4 = j; i__4 = j;
x[i__4].r = temp.r, x[i__4].i = temp.i; x[i__4].r = temp.r, x[i__4].i = temp.i;
/* L170: */ /* L170: */
} }
} else { } else {
jx = kx; jx = kx;
@ -586,54 +536,45 @@
if (noconj) { if (noconj) {
if (nounit) { if (nounit) {
i__4 = j * a_dim1 + 1; i__4 = j * a_dim1 + 1;
z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, z__1.i = temp.r * a[i__4].i + temp.i * a[i__4].r;
z__1.i = temp.r * a[i__4].i + temp.i * a[
i__4].r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
i__1 = l + i__ + j * a_dim1; i__1 = l + i__ + j * a_dim1;
i__2 = ix; i__2 = ix;
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[i__2].i,
i__2].i, z__2.i = a[i__1].r * x[i__2].i + z__2.i = a[i__1].r * x[i__2].i + a[i__1].i * x[i__2].r;
a[i__1].i * x[i__2].r; z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
ix += *incx; ix += *incx;
/* L180: */ /* L180: */
} }
} else { } else {
if (nounit) { if (nounit) {
d_cnjg(&z__2, &a[j * a_dim1 + 1]); d_cnjg(&z__2, &a[j * a_dim1 + 1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.r = temp.r * z__2.r - temp.i * z__2.i, z__1.i = temp.r * z__2.i + temp.i * z__2.r;
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
} }
/* Computing MIN */ /* Computing MIN */
i__1 = *n, i__2 = j + *k; i__1 = *n, i__2 = j + *k;
i__4 = min(i__1,i__2); i__4 = min(i__1, i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) { for (i__ = j + 1; i__ <= i__4; ++i__) {
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
i__1 = ix; i__1 = ix;
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, z__2.i = z__3.r * x[i__1].i + z__3.i * x[i__1].r;
z__2.i = z__3.r * x[i__1].i + z__3.i * x[ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
i__1].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i; temp.r = z__1.r, temp.i = z__1.i;
ix += *incx; ix += *incx;
/* L190: */ /* L190: */
} }
} }
i__4 = jx; i__4 = jx;
x[i__4].r = temp.r, x[i__4].i = temp.i; x[i__4].r = temp.r, x[i__4].i = temp.i;
jx += *incx; jx += *incx;
/* L200: */ /* L200: */
} }
} }
} }
@ -641,7 +582,6 @@
return 0; return 0;
/* End of ZTBMV . */ /* End of ZTBMV . */
} /* ztbmv_ */ } /* ztbmv_ */

69
lapack/cholesky.inc
View File

@ -11,26 +11,28 @@
#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) if (ret >= 0) *info = ret + 1;
*info = ret+1;
return 0; return 0;
} }
@ -38,32 +40,33 @@ EIGEN_LAPACK_FUNC(potrf,(char* uplo, int *n, RealScalar *pa, int *lda, int *info
// 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);
} }

57
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;
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) 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) mat = matrix(a,*n,*n,*lda).adjoint(); if (UPLO(*uplo) == UP)
else mat = matrix(a,*n,*n,*lda); mat = matrix(a, *n, *n, *lda).adjoint();
else
mat = matrix(a, *n, *n, *lda);
bool computeVectors = *jobz=='V' || *jobz=='v'; bool computeVectors = *jobz == 'V' || *jobz == 'v';
SelfAdjointEigenSolver<PlainMatrixType> eig(mat,computeVectors?ComputeEigenvectors:EigenvaluesOnly); 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) matrix(a, *n, *n, *lda).setIdentity();
if(computeVectors)
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;
} }

89
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;
} }

169
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))
*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) 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) 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 = *jobz=='A' ? ComputeFullU|ComputeFullV int option = *jobz == 'A' ? ComputeFullU | ComputeFullV
: *jobz=='S' ? ComputeThinU|ComputeThinV : *jobz == 'S' ? ComputeThinU | ComputeThinV
: *jobz=='O' ? ComputeThinU|ComputeThinV : *jobz == 'O' ? ComputeThinU | ComputeThinV
: 0; : 0;
BDCSVD<PlainMatrixType> svd(mat,option); BDCSVD<PlainMatrixType> svd(mat, option);
make_vector(s,diag_size) = svd.singularValues().head(diag_size); make_vector(s, diag_size) = svd.singularValues().head(diag_size);
if(*jobz=='A') if (*jobz == 'A') {
{ matrix(u, *m, *m, *ldu) = svd.matrixU();
matrix(u,*m,*m,*ldu) = svd.matrixU(); matrix(vt, *n, *n, *ldvt) = svd.matrixV().adjoint();
matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint(); } else if (*jobz == 'S') {
} matrix(u, *m, diag_size, *ldu) = svd.matrixU();
else if(*jobz=='S') matrix(vt, diag_size, *n, *ldvt) = svd.matrixV().adjoint();
{ } else if (*jobz == 'O' && *m >= *n) {
matrix(u,*m,diag_size,*ldu) = svd.matrixU(); matrix(a, *m, *n, *lda) = svd.matrixU();
matrix(vt,diag_size,*n,*ldvt) = svd.matrixV().adjoint(); matrix(vt, *n, *n, *ldvt) = svd.matrixV().adjoint();
} } else if (*jobz == 'O') {
else if(*jobz=='O' && *m>=*n) matrix(u, *m, *m, *ldu) = svd.matrixU();
{ matrix(a, diag_size, *n, *lda) = svd.matrixV().adjoint();
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;
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) 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 : *jobu=='S' || *jobu=='O' ? ComputeThinU : 0) int option = (*jobu == 'A' ? ComputeFullU
| (*jobv=='A' ? ComputeFullV : *jobv=='S' || *jobv=='O' ? ComputeThinV : 0); : *jobu == 'S' || *jobu == 'O' ? ComputeThinU
: 0) |
(*jobv == 'A' ? ComputeFullV
: *jobv == 'S' || *jobv == 'O' ? ComputeThinV
: 0);
JacobiSVD<PlainMatrixType> svd(mat,option); JacobiSVD<PlainMatrixType> svd(mat, option);
make_vector(s,diag_size) = svd.singularValues().head(diag_size); 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;
} }