/*! _zrovector*zgbmatrix operator */
inline _zrovector operator*(const _zrovector& vec, const zgbmatrix& mat)
{
#ifdef  CPPL_VERBOSE
  std::cerr << "# [MARK] operator*(const _zrovector&, const zgbmatrix&)"
            << std::endl;
#endif//CPPL_VERBOSE
  
#ifdef  CPPL_DEBUG
  if(vec.L!=mat.M){
    std::cerr << "[ERROR] operator*(const _zrovector&, const zgbmatrix&)"
              << std::endl
              << "These vector and matrix can not make a product."
              << std::endl
              << "Your input was (" << vec.L << ") * ("
              << mat.M << "x" << mat.N << ")." << std::endl;
    exit(1);
  }
#endif//CPPL_DEBUG
  
  zrovector newvec(mat.N);
  zgbmv_( 'T', mat.M, mat.N, mat.KL, mat.KU, std::complex<double>(1.0,0.0),
          mat.Array, mat.KL+mat.KU+1, vec.Array, 1, std::complex<double>(0.0,0.0), newvec.array, 1 );
  
  vec.destroy();
  return _(newvec);
}
Exemplo n.º 2
0
int 
f2c_zgbmv(char *trans, integer *M, integer *N, integer *KL, integer *KU, 
          doublecomplex *alpha, 
          doublecomplex *A, integer *lda, 
          doublecomplex *X, integer *incX, 
          doublecomplex *beta, 
          doublecomplex *Y, integer *incY)
{
    zgbmv_(trans, M, N, KL, KU,
           alpha, A, lda, X, incX, beta, Y, incY);
    return 0;
}
Exemplo n.º 3
0
/*! _zgbmatrix*zcovector operator */
inline _zcovector operator*(const _zgbmatrix& mat, const zcovector& vec)
{VERBOSE_REPORT;
#ifdef  CPPL_DEBUG
  if(mat.n!=vec.l){
    ERROR_REPORT;
    std::cerr << "These matrix and vector can not make a product." << std::endl
              << "Your input was (" << mat.m << "x" << mat.n << ") * (" << vec.l << ")." << std::endl;
    exit(1);
  }
#endif//CPPL_DEBUG
  
  zcovector newvec(mat.m);
  zgbmv_( 'n', mat.m, mat.n, mat.kl, mat.ku, comple(1.0,0.0), mat.array,
          mat.kl+mat.ku+1, vec.array, 1, comple(0.0,0.0), newvec.array, 1 );
  
  mat.destroy();
  return _(newvec);
}
Exemplo n.º 4
0
/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer *
	ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *
	afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb, 
	doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, 
	doublecomplex *work, doublereal *rwork, integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, 
	    x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;

    /* Builtin functions */
    double d_imag(doublecomplex *);

    /* Local variables */
    integer i__, j, k;
    doublereal s;
    integer kk;
    doublereal xk;
    integer nz;
    doublereal eps;
    integer kase;
    doublereal safe1, safe2;
    extern logical lsame_(char *, char *);
    integer isave[3];
    extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
, integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *);
    integer count;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
	    integer *, doublecomplex *, doublecomplex *, doublereal *, 
	    integer *, integer *);
    extern doublereal dlamch_(char *);
    doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    logical notran;
    char transn[1], transt[1];
    doublereal lstres;
    extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer 
	    *, integer *, doublecomplex *, integer *, integer *, 
	    doublecomplex *, integer *, integer *);


/*  -- LAPACK routine (version 3.2) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  ZGBRFS improves the computed solution to a system of linear */
/*  equations when the coefficient matrix is banded, and provides */
/*  error bounds and backward error estimates for the solution. */

/*  Arguments */
/*  ========= */

/*  TRANS   (input) CHARACTER*1 */
/*          Specifies the form of the system of equations: */
/*          = 'N':  A * X = B     (No transpose) */
/*          = 'T':  A**T * X = B  (Transpose) */
/*          = 'C':  A**H * X = B  (Conjugate transpose) */

/*  N       (input) INTEGER */
/*          The order of the matrix A.  N >= 0. */

/*  KL      (input) INTEGER */
/*          The number of subdiagonals within the band of A.  KL >= 0. */

/*  KU      (input) INTEGER */
/*          The number of superdiagonals within the band of A.  KU >= 0. */

/*  NRHS    (input) INTEGER */
/*          The number of right hand sides, i.e., the number of columns */
/*          of the matrices B and X.  NRHS >= 0. */

/*  AB      (input) COMPLEX*16 array, dimension (LDAB,N) */
/*          The original band matrix A, stored in rows 1 to KL+KU+1. */
/*          The j-th column of A is stored in the j-th column of the */
/*          array AB as follows: */
/*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */

/*  LDAB    (input) INTEGER */
/*          The leading dimension of the array AB.  LDAB >= KL+KU+1. */

/*  AFB     (input) COMPLEX*16 array, dimension (LDAFB,N) */
/*          Details of the LU factorization of the band matrix A, as */
/*          computed by ZGBTRF.  U is stored as an upper triangular band */
/*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/*          the multipliers used during the factorization are stored in */
/*          rows KL+KU+2 to 2*KL+KU+1. */

/*  LDAFB   (input) INTEGER */
/*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1. */

/*  IPIV    (input) INTEGER array, dimension (N) */
/*          The pivot indices from ZGBTRF; for 1<=i<=N, row i of the */
/*          matrix was interchanged with row IPIV(i). */

/*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/*          The right hand side matrix B. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B.  LDB >= max(1,N). */

/*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
/*          On entry, the solution matrix X, as computed by ZGBTRS. */
/*          On exit, the improved solution matrix X. */

/*  LDX     (input) INTEGER */
/*          The leading dimension of the array X.  LDX >= max(1,N). */

/*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS) */
/*          The estimated forward error bound for each solution vector */
/*          X(j) (the j-th column of the solution matrix X). */
/*          If XTRUE is the true solution corresponding to X(j), FERR(j) */
/*          is an estimated upper bound for the magnitude of the largest */
/*          element in (X(j) - XTRUE) divided by the magnitude of the */
/*          largest element in X(j).  The estimate is as reliable as */
/*          the estimate for RCOND, and is almost always a slight */
/*          overestimate of the true error. */

/*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS) */
/*          The componentwise relative backward error of each solution */
/*          vector X(j) (i.e., the smallest relative change in */
/*          any element of A or B that makes X(j) an exact solution). */

/*  WORK    (workspace) COMPLEX*16 array, dimension (2*N) */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N) */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */

/*  Internal Parameters */
/*  =================== */

/*  ITMAX is the maximum number of steps of iterative refinement. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Statement Functions .. */
/*     .. */
/*     .. Statement Function definitions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input parameters. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    afb_dim1 = *ldafb;
    afb_offset = 1 + afb_dim1;
    afb -= afb_offset;
    --ipiv;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    --ferr;
    --berr;
    --work;
    --rwork;

    /* Function Body */
    *info = 0;
    notran = lsame_(trans, "N");
    if (! notran && ! lsame_(trans, "T") && ! lsame_(
	    trans, "C")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kl < 0) {
	*info = -3;
    } else if (*ku < 0) {
	*info = -4;
    } else if (*nrhs < 0) {
	*info = -5;
    } else if (*ldab < *kl + *ku + 1) {
	*info = -7;
    } else if (*ldafb < (*kl << 1) + *ku + 1) {
	*info = -9;
    } else if (*ldb < max(1,*n)) {
	*info = -12;
    } else if (*ldx < max(1,*n)) {
	*info = -14;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGBRFS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0 || *nrhs == 0) {
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    ferr[j] = 0.;
	    berr[j] = 0.;
/* L10: */
	}
	return 0;
    }

    if (notran) {
	*(unsigned char *)transn = 'N';
	*(unsigned char *)transt = 'C';
    } else {
	*(unsigned char *)transn = 'C';
	*(unsigned char *)transt = 'N';
    }

/*     NZ = maximum number of nonzero elements in each row of A, plus 1 */

/* Computing MIN */
    i__1 = *kl + *ku + 2, i__2 = *n + 1;
    nz = min(i__1,i__2);
    eps = dlamch_("Epsilon");
    safmin = dlamch_("Safe minimum");
    safe1 = nz * safmin;
    safe2 = safe1 / eps;

/*     Do for each right hand side */

    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {

	count = 1;
	lstres = 3.;
L20:

/*        Loop until stopping criterion is satisfied. */

/*        Compute residual R = B - op(A) * X, */
/*        where op(A) = A, A**T, or A**H, depending on TRANS. */

	zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
	z__1.r = -1., z__1.i = -0.;
	zgbmv_(trans, n, n, kl, ku, &z__1, &ab[ab_offset], ldab, &x[j * 
		x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1);

/*        Compute componentwise relative backward error from formula */

/*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */

/*        where abs(Z) is the componentwise absolute value of the matrix */
/*        or vector Z.  If the i-th component of the denominator is less */
/*        than SAFE2, then SAFE1 is added to the i-th components of the */
/*        numerator and denominator before dividing. */

	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = i__ + j * b_dim1;
	    rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
		    i__ + j * b_dim1]), abs(d__2));
/* L30: */
	}

/*        Compute abs(op(A))*abs(X) + abs(B). */

	if (notran) {
	    i__2 = *n;
	    for (k = 1; k <= i__2; ++k) {
		kk = *ku + 1 - k;
		i__3 = k + j * x_dim1;
		xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
			 x_dim1]), abs(d__2));
/* Computing MAX */
		i__3 = 1, i__4 = k - *ku;
/* Computing MIN */
		i__6 = *n, i__7 = k + *kl;
		i__5 = min(i__6,i__7);
		for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
		    i__3 = kk + i__ + k * ab_dim1;
		    rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = 
			    d_imag(&ab[kk + i__ + k * ab_dim1]), abs(d__2))) *
			     xk;
/* L40: */
		}
/* L50: */
	    }
	} else {
	    i__2 = *n;
	    for (k = 1; k <= i__2; ++k) {
		s = 0.;
		kk = *ku + 1 - k;
/* Computing MAX */
		i__5 = 1, i__3 = k - *ku;
/* Computing MIN */
		i__6 = *n, i__7 = k + *kl;
		i__4 = min(i__6,i__7);
		for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
		    i__5 = kk + i__ + k * ab_dim1;
		    i__3 = i__ + j * x_dim1;
		    s += ((d__1 = ab[i__5].r, abs(d__1)) + (d__2 = d_imag(&ab[
			    kk + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 = 
			    x[i__3].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j 
			    * x_dim1]), abs(d__4)));
/* L60: */
		}
		rwork[k] += s;
/* L70: */
	    }
	}
	s = 0.;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    if (rwork[i__] > safe2) {
/* Computing MAX */
		i__4 = i__;
		d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 = 
			d_imag(&work[i__]), abs(d__2))) / rwork[i__];
		s = max(d__3,d__4);
	    } else {
/* Computing MAX */
		i__4 = i__;
		d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 = 
			d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__] 
			+ safe1);
		s = max(d__3,d__4);
	    }
/* L80: */
	}
	berr[j] = s;

/*        Test stopping criterion. Continue iterating if */
/*           1) The residual BERR(J) is larger than machine epsilon, and */
/*           2) BERR(J) decreased by at least a factor of 2 during the */
/*              last iteration, and */
/*           3) At most ITMAX iterations tried. */

	if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {

/*           Update solution and try again. */

	    zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
, &work[1], n, info);
	    zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
	    lstres = berr[j];
	    ++count;
	    goto L20;
	}

/*        Bound error from formula */

/*        norm(X - XTRUE) / norm(X) .le. FERR = */
/*        norm( abs(inv(op(A)))* */
/*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */

/*        where */
/*          norm(Z) is the magnitude of the largest component of Z */
/*          inv(op(A)) is the inverse of op(A) */
/*          abs(Z) is the componentwise absolute value of the matrix or */
/*             vector Z */
/*          NZ is the maximum number of nonzeros in any row of A, plus 1 */
/*          EPS is machine epsilon */

/*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
/*        is incremented by SAFE1 if the i-th component of */
/*        abs(op(A))*abs(X) + abs(B) is less than SAFE2. */

/*        Use ZLACN2 to estimate the infinity-norm of the matrix */
/*           inv(op(A)) * diag(W), */
/*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */

	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    if (rwork[i__] > safe2) {
		i__4 = i__;
		rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 = 
			d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
			;
	    } else {
		i__4 = i__;
		rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 = 
			d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
			 + safe1;
	    }
/* L90: */
	}

	kase = 0;
L100:
	zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
	if (kase != 0) {
	    if (kase == 1) {

/*              Multiply by diag(W)*inv(op(A)**H). */

		zgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
			ipiv[1], &work[1], n, info);
		i__2 = *n;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    i__4 = i__;
		    i__5 = i__;
		    i__3 = i__;
		    z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5] 
			    * work[i__3].i;
		    work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L110: */
		}
	    } else {

/*              Multiply by inv(op(A))*diag(W). */

		i__2 = *n;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    i__4 = i__;
		    i__5 = i__;
		    i__3 = i__;
		    z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5] 
			    * work[i__3].i;
		    work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L120: */
		}
		zgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
			ipiv[1], &work[1], n, info);
	    }
	    goto L100;
	}

/*        Normalize error. */

	lstres = 0.;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
	    i__4 = i__ + j * x_dim1;
	    d__3 = lstres, d__4 = (d__1 = x[i__4].r, abs(d__1)) + (d__2 = 
		    d_imag(&x[i__ + j * x_dim1]), abs(d__2));
	    lstres = max(d__3,d__4);
/* L130: */
	}
	if (lstres != 0.) {
	    ferr[j] /= lstres;
	}

/* L140: */
    }

    return 0;

/*     End of ZGBRFS */

} /* zgbrfs_ */
Exemplo n.º 5
0
void
zgbmv(char trans, int m, int n, int kl, int ku, doublecomplex *alpha, doublecomplex *a, int inca, doublecomplex *x, int incx, doublecomplex *beta, doublecomplex *y, int incy )
{
   zgbmv_( &trans, &m, &n, &kl, &ku, alpha, a, &inca, x, &incx, beta, y, &incy );
}
Exemplo n.º 6
0
/* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans, 
	 integer *m, integer *n, integer *kl, integer *ku, integer *nrhs, 
	doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx, 
	doublecomplex *b, integer *ldb, integer *iseed, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;

    /* Local variables */
    integer j;
    char c1[1], c2[2];
    integer mb, nx;
    logical gen, tri, qrs, sym, band;
    char diag[1];
    logical tran;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), zhemm_(char *, char *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), zgbmv_(char *, integer *, integer *, 
	    integer *, integer *, doublecomplex *, doublecomplex *, integer *, 
	     doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), zhbmv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *), 
	    zsbmv_(char *, integer *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, doublecomplex *, integer *), ztbmv_(char 
	    *, char *, char *, integer *, integer *, doublecomplex *, integer 
	    *, doublecomplex *, integer *), zhpmv_(
	    char *, integer *, doublecomplex *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), ztrmm_(char *, char *, char *, char *, 
	    integer *, integer *, doublecomplex *, doublecomplex *, integer *, 
	     doublecomplex *, integer *), 
	    zspmv_(char *, integer *, doublecomplex *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), zsymm_(char *, char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *
, doublecomplex *, integer *), xerbla_(
	    char *, integer *);
    extern logical lsamen_(integer *, char *, char *);
    logical notran;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), 
	    zlarnv_(integer *, integer *, integer *, doublecomplex *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  ZLARHS chooses a set of NRHS random solution vectors and sets */
/*  up the right hand sides for the linear system */
/*     op( A ) * X = B, */
/*  where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
/*  transpose of A). */

/*  Arguments */
/*  ========= */

/*  PATH    (input) CHARACTER*3 */
/*          The type of the complex matrix A.  PATH may be given in any */
/*          combination of upper and lower case.  Valid paths include */
/*             xGE:  General m x n matrix */
/*             xGB:  General banded matrix */
/*             xPO:  Hermitian positive definite, 2-D storage */
/*             xPP:  Hermitian positive definite packed */
/*             xPB:  Hermitian positive definite banded */
/*             xHE:  Hermitian indefinite, 2-D storage */
/*             xHP:  Hermitian indefinite packed */
/*             xHB:  Hermitian indefinite banded */
/*             xSY:  Symmetric indefinite, 2-D storage */
/*             xSP:  Symmetric indefinite packed */
/*             xSB:  Symmetric indefinite banded */
/*             xTR:  Triangular */
/*             xTP:  Triangular packed */
/*             xTB:  Triangular banded */
/*             xQR:  General m x n matrix */
/*             xLQ:  General m x n matrix */
/*             xQL:  General m x n matrix */
/*             xRQ:  General m x n matrix */
/*          where the leading character indicates the precision. */

/*  XTYPE   (input) CHARACTER*1 */
/*          Specifies how the exact solution X will be determined: */
/*          = 'N':  New solution; generate a random X. */
/*          = 'C':  Computed; use value of X on entry. */

/*  UPLO    (input) CHARACTER*1 */
/*          Used only if A is symmetric or triangular; specifies whether */
/*          the upper or lower triangular part of the matrix A is stored. */
/*          = 'U':  Upper triangular */
/*          = 'L':  Lower triangular */

/*  TRANS   (input) CHARACTER*1 */
/*          Used only if A is nonsymmetric; specifies the operation */
/*          applied to the matrix A. */
/*          = 'N':  B := A    * X */
/*          = 'T':  B := A**T * X */
/*          = 'C':  B := A**H * X */

/*  M       (input) INTEGER */
/*          The number of rows of the matrix A.  M >= 0. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrix A.  N >= 0. */

/*  KL      (input) INTEGER */
/*          Used only if A is a band matrix; specifies the number of */
/*          subdiagonals of A if A is a general band matrix or if A is */
/*          symmetric or triangular and UPLO = 'L'; specifies the number */
/*          of superdiagonals of A if A is symmetric or triangular and */
/*          UPLO = 'U'.  0 <= KL <= M-1. */

/*  KU      (input) INTEGER */
/*          Used only if A is a general band matrix or if A is */
/*          triangular. */

/*          If PATH = xGB, specifies the number of superdiagonals of A, */
/*          and 0 <= KU <= N-1. */

/*          If PATH = xTR, xTP, or xTB, specifies whether or not the */
/*          matrix has unit diagonal: */
/*          = 1:  matrix has non-unit diagonal (default) */
/*          = 2:  matrix has unit diagonal */

/*  NRHS    (input) INTEGER */
/*          The number of right hand side vectors in the system A*X = B. */

/*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
/*          The test matrix whose type is given by PATH. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A. */
/*          If PATH = xGB, LDA >= KL+KU+1. */
/*          If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
/*          Otherwise, LDA >= max(1,M). */

/*  X       (input or output) COMPLEX*16  array, dimension (LDX,NRHS) */
/*          On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
/*          the exact solution to the system of linear equations. */
/*          On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
/*          with random values. */

/*  LDX     (input) INTEGER */
/*          The leading dimension of the array X.  If TRANS = 'N', */
/*          LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */

/*  B       (output) COMPLEX*16  array, dimension (LDB,NRHS) */
/*          The right hand side vector(s) for the system of equations, */
/*          computed from B = op(A) * X, where op(A) is determined by */
/*          TRANS. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B.  If TRANS = 'N', */
/*          LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */

/*  ISEED   (input/output) INTEGER array, dimension (4) */
/*          The seed vector for the random number generator (used in */
/*          ZLATMS).  Modified on exit. */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input parameters. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --iseed;

    /* Function Body */
    *info = 0;
    *(unsigned char *)c1 = *(unsigned char *)path;
    s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
    tran = lsame_(trans, "T") || lsame_(trans, "C");
    notran = ! tran;
    gen = lsame_(path + 1, "G");
    qrs = lsame_(path + 1, "Q") || lsame_(path + 2, 
	    "Q");
    sym = lsame_(path + 1, "P") || lsame_(path + 1, 
	    "S") || lsame_(path + 1, "H");
    tri = lsame_(path + 1, "T");
    band = lsame_(path + 2, "B");
    if (! lsame_(c1, "Zomplex precision")) {
	*info = -1;
    } else if (! (lsame_(xtype, "N") || lsame_(xtype, 
	    "C"))) {
	*info = -2;
    } else if ((sym || tri) && ! (lsame_(uplo, "U") || 
	    lsame_(uplo, "L"))) {
	*info = -3;
    } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
	*info = -4;
    } else if (*m < 0) {
	*info = -5;
    } else if (*n < 0) {
	*info = -6;
    } else if (band && *kl < 0) {
	*info = -7;
    } else if (band && *ku < 0) {
	*info = -8;
    } else if (*nrhs < 0) {
	*info = -9;
    } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
	    kl + 1 || band && gen && *lda < *kl + *ku + 1) {
	*info = -11;
    } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
	*info = -13;
    } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
	*info = -15;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZLARHS", &i__1);
	return 0;
    }

/*     Initialize X to NRHS random vectors unless XTYPE = 'C'. */

    if (tran) {
	nx = *m;
	mb = *n;
    } else {
	nx = *n;
	mb = *m;
    }
    if (! lsame_(xtype, "C")) {
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
/* L10: */
	}
    }

/*     Multiply X by op( A ) using an appropriate */
/*     matrix multiply routine. */

    if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2, 
	    "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") || 
	    lsamen_(&c__2, c2, "RQ")) {

/*        General matrix */

	zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
		x_offset], ldx, &c_b2, &b[b_offset], ldb);

    } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
	    c__2, c2, "HE")) {

/*        Hermitian matrix, 2-D storage */

	zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], 
		ldx, &c_b2, &b[b_offset], ldb);

    } else if (lsamen_(&c__2, c2, "SY")) {

/*        Symmetric matrix, 2-D storage */

	zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], 
		ldx, &c_b2, &b[b_offset], ldb);

    } else if (lsamen_(&c__2, c2, "GB")) {

/*        General matrix, band storage */

	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j * 
		    x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L20: */
	}

    } else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
	    c__2, c2, "HB")) {

/*        Hermitian matrix, band storage */

	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], 
		    &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L30: */
	}

    } else if (lsamen_(&c__2, c2, "SB")) {

/*        Symmetric matrix, band storage */

	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], 
		    &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L40: */
	}

    } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
	    c__2, c2, "HP")) {

/*        Hermitian matrix, packed storage */

	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
		    c_b2, &b[j * b_dim1 + 1], &c__1);
/* L50: */
	}

    } else if (lsamen_(&c__2, c2, "SP")) {

/*        Symmetric matrix, packed storage */

	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
		    c_b2, &b[j * b_dim1 + 1], &c__1);
/* L60: */
	}

    } else if (lsamen_(&c__2, c2, "TR")) {

/*        Triangular matrix.  Note that for triangular matrices, */
/*           KU = 1 => non-unit triangular */
/*           KU = 2 => unit triangular */

	zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
	if (*ku == 2) {
	    *(unsigned char *)diag = 'U';
	} else {
	    *(unsigned char *)diag = 'N';
	}
	ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
		b[b_offset], ldb);

    } else if (lsamen_(&c__2, c2, "TP")) {

/*        Triangular matrix, packed storage */

	zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
	if (*ku == 2) {
	    *(unsigned char *)diag = 'U';
	} else {
	    *(unsigned char *)diag = 'N';
	}
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
		    c__1);
/* L70: */
	}

    } else if (lsamen_(&c__2, c2, "TB")) {

/*        Triangular matrix, banded storage */

	zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
	if (*ku == 2) {
	    *(unsigned char *)diag = 'U';
	} else {
	    *(unsigned char *)diag = 'N';
	}
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1 
		    + 1], &c__1);
/* L80: */
	}

    } else {

/*        If none of the above, set INFO = -1 and return */

	*info = -1;
	i__1 = -(*info);
	xerbla_("ZLARHS", &i__1);
    }

    return 0;

/*     End of ZLARHS */

} /* zlarhs_ */
Exemplo n.º 7
0
void cblas_zgbmv(const enum CBLAS_ORDER order,
                 const enum CBLAS_TRANSPOSE TransA, const integer M, const integer N,
                 const integer KL, const integer KU,
                 const void *alpha, const void  *A, const integer lda,
                 const void  *X, const integer incX, const void *beta,
                 void  *Y, const integer incY)
{
   char TA;
#ifdef F77_CHAR
   F77_CHAR F77_TA;
#else
   #define F77_TA &TA   
#endif
   #define F77_M M
   #define F77_N N
   #define F77_lda lda
   #define F77_KL KL
   #define F77_KU KU
   #define F77_incX incx
   #define F77_incY incY
   integer n, i=0, incx=incX;
   const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta;
   double ALPHA[2],BETA[2];
   integer tincY, tincx;
   double *x=(double *)X, *y=(double *)Y, *st=0, *tx;
   extern integer CBLAS_CallFromC;
   extern integer RowMajorStrg;
   RowMajorStrg = 0;

   CBLAS_CallFromC = 1;
   if (order == CblasColMajor)
   {
      if (TransA == CblasNoTrans) TA = 'N';
      else if (TransA == CblasTrans) TA = 'T';
      else if (TransA == CblasConjTrans) TA = 'C';
      else 
      {
         cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA);
         CBLAS_CallFromC = 0;
         RowMajorStrg = 0;
         return;
      }
      #ifdef F77_CHAR
         F77_TA = C2F_CHAR(&TA);
      #endif
      zgbmv_(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha,  
                     A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY);
   }
   else if (order == CblasRowMajor)
   {
      RowMajorStrg = 1;
      if (TransA == CblasNoTrans) TA = 'T';
      else if (TransA == CblasTrans) TA = 'N';
      else if (TransA == CblasConjTrans)
      {
         ALPHA[0]= *alp;
         ALPHA[1]= -alp[1];
         BETA[0]= *bet;
         BETA[1]= -bet[1];
         TA = 'N';
         if (M > 0)
         {
            n = M << 1;
            x = malloc(n*sizeof(double));
            tx = x;

            if( incX > 0 ) {
               i = incX << 1 ;
               tincx = 2;
               st= x+n;
            } else {
               i = incX *(-2);
               tincx = -2;
               st = x-2;
               x +=(n-2);
            }
            do
            {
               *x = *xx;
               x[1] = -xx[1];
               x += tincx ;
               xx += i;
            }
            while (x != st);
            x=tx;

               incx = 1;

            if( incY > 0 )
              tincY = incY;
            else
              tincY = -incY;

            y++;
 
            if (N > 0)
            {
               i = tincY << 1;
               n = i * N ;
               st = y + n;
               do {
                  *y = -(*y);
                  y += i;
               } while(y != st);
               y -= n;
            }
         }
         else x = (double *) X;

 
      }
      else 
      {
         cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA);
         CBLAS_CallFromC = 0;
         RowMajorStrg = 0;
         return;
      }
      #ifdef F77_CHAR
         F77_TA = C2F_CHAR(&TA);
      #endif
      if (TransA == CblasConjTrans)
         zgbmv_(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, 
                        A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY);
      else
         zgbmv_(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, 
                        A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY);
      if (TransA == CblasConjTrans)
      {
         if (x != X) free(x);
         if (N > 0)
         {
            do
            {
               *y = -(*y);
               y += i;
            }
            while (y != st);
         }
      }
   }
   else cblas_xerbla(1, "cblas_zgbmv", "Illegal Order setting, %d\n", order);
   CBLAS_CallFromC = 0;
   RowMajorStrg = 0;
   return;
}
Exemplo n.º 8
0
/* Subroutine */ int zgbt02_(char *trans, integer *m, integer *n, integer *kl, 
	 integer *ku, integer *nrhs, doublecomplex *a, integer *lda, 
	doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb, 
	doublereal *resid)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, 
	    i__3;
    doublereal d__1, d__2;
    doublecomplex z__1;

    /* Local variables */
    integer j, i1, i2, n1, kd;
    doublereal eps;
    doublereal anorm, bnorm;
    doublereal xnorm;


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  ZGBT02 computes the residual for a solution of a banded system of */
/*  equations  A*x = b  or  A'*x = b: */
/*     RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
/*  where EPS is the machine precision. */

/*  Arguments */
/*  ========= */

/*  TRANS   (input) CHARACTER*1 */
/*          Specifies the form of the system of equations: */
/*          = 'N':  A *x = b */
/*          = 'T':  A'*x = b, where A' is the transpose of A */
/*          = 'C':  A'*x = b, where A' is the transpose of A */

/*  M       (input) INTEGER */
/*          The number of rows of the matrix A.  M >= 0. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrix A.  N >= 0. */

/*  KL      (input) INTEGER */
/*          The number of subdiagonals within the band of A.  KL >= 0. */

/*  KU      (input) INTEGER */
/*          The number of superdiagonals within the band of A.  KU >= 0. */

/*  NRHS    (input) INTEGER */
/*          The number of columns of B.  NRHS >= 0. */

/*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
/*          The original matrix A in band storage, stored in rows 1 to */
/*          KL+KU+1. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A.  LDA >= max(1,KL+KU+1). */

/*  X       (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/*          The computed solution vectors for the system of linear */
/*          equations. */

/*  LDX     (input) INTEGER */
/*          The leading dimension of the array X.  If TRANS = 'N', */
/*          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */

/*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/*          On entry, the right hand side vectors for the system of */
/*          linear equations. */
/*          On exit, B is overwritten with the difference B - A*X. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B.  IF TRANS = 'N', */
/*          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */

/*  RESID   (output) DOUBLE PRECISION */
/*          The maximum over the number of right hand sides of */
/*          norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick return if N = 0 pr NRHS = 0 */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;

    /* Function Body */
    if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
	*resid = 0.;
	return 0;
    }

/*     Exit with RESID = 1/EPS if ANORM = 0. */

    eps = dlamch_("Epsilon");
    kd = *ku + 1;
    anorm = 0.;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = kd + 1 - j;
	i1 = max(i__2,1);
/* Computing MIN */
	i__2 = kd + *m - j, i__3 = *kl + kd;
	i2 = min(i__2,i__3);
/* Computing MAX */
	i__2 = i2 - i1 + 1;
	d__1 = anorm, d__2 = dzasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
	anorm = max(d__1,d__2);
/* L10: */
    }
    if (anorm <= 0.) {
	*resid = 1. / eps;
	return 0;
    }

    if (lsame_(trans, "T") || lsame_(trans, "C")) {
	n1 = *n;
    } else {
	n1 = *m;
    }

/*     Compute  B - A*X (or  B - A'*X ) */

    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	z__1.r = -1., z__1.i = -0.;
	zgbmv_(trans, m, n, kl, ku, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 
		1], &c__1, &c_b1, &b[j * b_dim1 + 1], &c__1);
/* L20: */
    }

/*     Compute the maximum over the number of right hand sides of */
/*        norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */

    *resid = 0.;
    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	bnorm = dzasum_(&n1, &b[j * b_dim1 + 1], &c__1);
	xnorm = dzasum_(&n1, &x[j * x_dim1 + 1], &c__1);
	if (xnorm <= 0.) {
	    *resid = 1. / eps;
	} else {
/* Computing MAX */
	    d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
	    *resid = max(d__1,d__2);
	}
/* L30: */
    }

    return 0;

/*     End of ZGBT02 */

} /* zgbt02_ */