.packageName <- "Matrix"
hilbert <- function(n)
{   ## generate the Hilbert matrix of dimension n
    i <- 1:n
    Matrix(1 / outer(i - 1, i, "+"))
}
Matrix <-
    function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
{
    if (inherits(data, "Matrix")) return(data)
    if (is.matrix(data)) { val <- data }
    else {
        if (missing(nrow))
            nrow <- ceiling(length(data)/ncol)
        else if (missing(ncol))
            ncol <- ceiling(length(data)/nrow)
        val <- .Internal(matrix(data, nrow, ncol, byrow))
        dimnames(val) <- dimnames
    }
    class(val) <- "Matrix"
    val
}

print.Matrix <- function(x, ...)
{
    print(unclass(x), ...)
}

as.matrix.Matrix <- function(x)
{
    unclass(unpack(x))
}

solve.Matrix <- function(a, b, tol = 0, transpose = FALSE, ...)
{   ## short version of a solve method
    if (missing(b)) return(.Call("R_LapackPP_solve", a,
                                 NULL, PACKAGE="Matrix"))
    .Call("R_LapackPP_solve", a, b, PACKAGE="Matrix")
}

Hermitian.test <- function(x)
{
    if ((!inherits(x, "Matrix") && !is.matrix(x)) ||
        (nrow(x) != ncol(x))) return(Inf)
    if (is.complex(x)) return(max(Mod(x - t(Conj(x)))))
    max(x - t(x))
}

is.Hermitian <- function(x, tol = 0) { Hermitian.test(x) <= tol }

LowerTriangular.test <- function(x)
{
    if ((!inherits(x, "Matrix") && !is.matrix(x))) return(Inf)
    if (is.complex(x)) return(max(Mod(x[row(x) < col(x)])))
    max(abs(x[row(x) < col(x)]))
}

is.LowerTriangular <- function(x, tol = 0) { LowerTriangular.test(x) <= tol }

UpperTriangular.test <- function(x)
{
    if ((!inherits(x, "Matrix") && !is.matrix(x))) return(Inf)
    if (is.complex(x)) return(max(Mod(x[row(x) > col(x)])))
    max(abs(x[row(x) > col(x)]))
}

is.UpperTriangular <- function(x, tol = 0) { UpperTriangular.test(x) <= tol }

Orthogonal.test <- function(x, byrow = FALSE, normal = TRUE)
{
    if ((!inherits(x, "Matrix") && !is.matrix(x))) return(Inf)
    if (byrow) { x <- t(x) }
    xx <- crossprod(x)
    if (normal) {                       # check for orthonormal
        return(max(Mod(xx[row(xx) > col(xx)]), Mod(diag(xx) - 1)))
    }
    max(Mod(xx[row(xx) > col(xx)]))
}

Orthonormal.test <- function(x, byrow = FALSE)
{
    Orthogonal.test(x, byrow, normal = TRUE)
}

is.ColOrthonormal <- function(x, tol = sqrt(.Machine$double.eps))
{
    Orthonormal.test(x, byrow = FALSE) <= tol
}

is.RowOrthonormal <- function(x, tol = sqrt(.Machine$double.eps))
{
    Orthonormal.test(x, byrow = TRUE) <= tol
}

is.Orthonormal <- function(x, tol = sqrt(.Machine$double.eps), byrow = FALSE)
{
    if (byrow) return(is.RowOrthonormal(x, tol))
    is.ColOrthonormal(x, tol)
}

Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,
                         triangularity = c(TRUE, TRUE),
                         orthogonality = c(TRUE, TRUE), normality = c(TRUE, TRUE))
{
    val <- "Matrix"
    x <- as.matrix(x)
    if (symmetry) {
        if (is.Hermitian(x, tol)) val <- c("Hermitian", val)
    }
    if (triangularity[1]) {
        if (is.LowerTriangular(x, tol)) {
            val <- c("LowerTriangular", val)
            if (unit.diagonal)
                if (max(Mod(diag(x) - 1)) <= tol)
                    val <- c("UnitLowerTriangular", val)
        }
    }
    if (triangularity[2]) {
        if (is.UpperTriangular(x, tol)) {
            val <- c("UpperTriangular", val)
            if (unit.diagonal)
                if (max(Mod(diag(x) - 1)) <= tol)
                    val <- c("UnitUpperTriangular", val)
        }
    }
    if (orthogonality[1]) {
        if (is.ColOrthonormal(x, tol)) {
            val <- c("ColOrthoNormal", "ColOrthogonal", val)
        } else {
            if (Orthogonal.test(x, normal = FALSE) <= tol)
                val <- c("ColOrthogonal", val)
        }
    }
    if (orthogonality[2]) {
        if (normality[2] && is.RowOrthonormal(x, tol)) {
            val <- c("RowOrthoNormal", "RowOrthogonal", val)
        } else {
            if (Orthogonal.test(x, byrow = TRUE, normal = FALSE) <= tol)
                val <- c("RowOrthogonal", val)
        }
    }
    val
}

as.Matrix <- function(x, tol = .Machine$double.eps)
{
    if (inherits(x, "Matrix")) return(asObject(x, Matrix.class(x, tol = tol)))
    asObject(as.matrix(x), Matrix.class(x, tol = tol))
}

### $Id: SVD.R,v 1.3 2002/07/22 19:01:14 bates Exp $
###
### Copyright 2000-2000 Douglas M. Bates <bates@stat.wisc.edu>
###
### This file is part of the Matrix library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

SVD <- function(x, nu = min(dim(x)), nv = min(dim(x)))
{
    if (!is.numeric(x))
        stop("argument to SVD must be numeric")
    x <- as.matrix(x)
    .Call("R_LapackPP_svd", x, nu, nv, PACKAGE="Matrix")
}


#det.default <- function (x, method = c("qr", "eigenvalues"), ...)
#{
#    ## old version - in case anyone depends on it
#    if (!is.matrix(x) || (n <- ncol(x)) != nrow(x))
#        stop("x must be a square matrix")
#    method <- match.arg(method)
#    if (method == "qr") {
#        x <- prod(diag(qr(x)$qr))
#        if (n%%2 == 1)
#            x
#        else -x
#    }
#    else Re(prod(eigen(x, only.values = TRUE)$values))
#}


determinant.Matrix <- function(x, logarithm = TRUE, ...)
{
    .Call("R_LapackPP_det", x, as.logical(logarithm), PACKAGE="Matrix")
}

determinant.UnitLowerTriangular <- function(x, logarithm = TRUE, ...)
{
    logarithm <- as.logical(logarithm[1])
    asObject(list(modulus =
                 structure(ifelse(logarithm, 0., 1.), logarithm = logarithm),
                 sign = 1),
            call = match.call(),
            c("determinant.UnitLowerTriangular", "determinant"))
}

determinant.UnitUpperTriangular <- function(x, logarithm = TRUE, ...)
{
    logarithm <- as.logical(logarithm[1])
    asObject(list(modulus =
                 structure(ifelse(logarithm, 0., 1.), logarithm = logarithm),
                 sign = 1),
            call = match.call(),
            c("determinant.UnitUpperTriangular", "determinant"))
}

## calculate the determinant of a triangular matrix from its diagonal
diagDet <- function(x, logarithm = TRUE, ...)
{
    logarithm <- as.logical(logarithm)[1]
    asObject(list(modulus =
                 structure(if (logarithm) sum(log(abs(x))) else prod(abs(x)),
                           logarithm = logarithm),
                 sign = prod(sign(x))),
            "determinant")
}

determinant.LowerTriangular <- function(x, logarithm = TRUE, ...)
    asObject(diagDet(x, logarithm), c("determinant.LowerTriangular", "determinant"))

determinant.UpperTriangular <- function(x, logarithm = TRUE, ...)
    asObject(diagDet(x, logarithm), c("determinant.UpperTriangular", "determinant"))
eigen.default <- function (x, symmetric, only.values = FALSE, ...)
{
    x <- as.matrix(x)
    n <- nrow(x)
    if (n != ncol(x))
        stop("non-square matrix in eigen")
    complex.x <- is.complex(x)
    if (complex.x) {
        if (missing(symmetric))
            symmetric <- all(x == Conj(t(x)))
    }
    else if (is.numeric(x)) {
        storage.mode(x) <- "double"
        if (missing(symmetric))
            symmetric <- all(x == t(x))
    }
    else stop("numeric or complex values required in eigen")
    dbl.n <- double(n)
    if (symmetric) {
        if (complex.x) {
            xr <- Re(x)
            xi <- Im(x)
            z <- .Fortran("ch", n, n, xr, xi, values = dbl.n,
                !only.values, vectors = xr, ivectors = xi, dbl.n,
                dbl.n, double(2 * n), ierr = integer(1), PACKAGE = "base")
            if (z$ierr)
                stop(paste("ch returned code ", z$ierr, " in eigen"))
            if (!only.values)
                z$vectors <- matrix(complex(re = z$vectors, im = z$ivectors),
                  nc = n)
        }
        else {
            z <- .Fortran("rs", n, n, x, values = dbl.n, !only.values,
                vectors = x, dbl.n, dbl.n, ierr = integer(1),
                PACKAGE = "base")
            if (z$ierr)
                stop(paste("rs returned code ", z$ierr, " in eigen"))
        }
        ord <- rev(order(z$values))
    }
    else {
        if (complex.x) {
            xr <- Re(x)
            xi <- Im(x)
            z <- .Fortran("cg", n, n, xr, xi, values = dbl.n,
                ivalues = dbl.n, !only.values, vectors = xr,
                ivectors = xi, dbl.n, dbl.n, dbl.n, ierr = integer(1),
                PACKAGE = "base")
            if (z$ierr)
                stop(paste("cg returned code ", z$ierr, " in eigen"))
            z$values <- complex(re = z$values, im = z$ivalues)
            if (!only.values)
                z$vectors <- matrix(complex(re = z$vectors, im = z$ivectors),
                  nc = n)
        }
        else {
            z <- .Fortran("rg", n, n, x, values = dbl.n, ivalues = dbl.n,
                !only.values, vectors = x, integer(n), dbl.n,
                ierr = integer(1), PACKAGE = "base")
            if (z$ierr)
                stop(paste("rg returned code ", z$ierr, " in eigen"))
            ind <- z$ivalues > 0
            if (any(ind)) {
                ind <- seq(n)[ind]
                z$values <- complex(re = z$values, im = z$ivalues)
                if (!only.values) {
                  z$vectors[, ind] <- complex(re = z$vectors[,
                    ind], im = z$vectors[, ind + 1])
                  z$vectors[, ind + 1] <- Conj(z$vectors[, ind])
                }
            }
        }
        ord <- rev(order(Mod(z$values)))
    }
    list(values = z$values[ord], vectors = if (!only.values) z$vectors[,
        ord])
}

eigen.Matrix <- function(x, vectors = TRUE, balance = "B", rcond = "N", ...)
{
    .Call("R_LapackPP_eigen", x, as.logical(vectors), as.character(balance),
          as.character(rcond), PACKAGE="Matrix")
}

schur.Matrix <- function(x, vectors = TRUE, ...)
{
    .Call("R_LapackPP_Schur", x, as.logical(vectors), PACKAGE="Matrix")
}

#determinant <- function(x, ...) UseMethod("determinant")
eigen <- function(x, ...) UseMethod("eigen")
expand <- function(x, ...) UseMethod("expand")
expand.default <- function(x, ...) x

facmul<- function(x, factor, y, transpose = FALSE, left = TRUE, ...)
    UseMethod("facmul")

lu <- function(x, ...) UseMethod("lu")

norm <- function(x, ...) UseMethod("norm")
norm.Matrix <- function(x, type = "M", ...)
    .Call("R_LapackPP_norm", x, as.character(type), PACKAGE="Matrix")
norm.default <- function(x, type = "M", ...)
    .Call("R_LapackPP_norm", as.matrix(x),
          as.character(type), PACKAGE="Matrix")

rcond <- function(x, ...) UseMethod("rcond")
rcond.Matrix <- function(x, type = "O", ...)
    .Call("R_LapackPP_rcond", x, as.character(type), PACKAGE="Matrix")
rcond.default <- function(x, type = "O", ...)
    .Call("R_LapackPP_rcond", as.matrix(x),
          as.character(type), PACKAGE="Matrix")

schur <- function(x, ...) UseMethod("schur")

unpack <- function(x, ...) UseMethod("unpack")
unpack.default <- function(x, ...) x

asObject <- function(x, cl) {class(x) <- as.character(cl); x}

prependClass <- function(x, cl) {class(x) <- c(as.character(cl), class(x)); x}
lu.Matrix <- function(x, norm.comp = c(one = TRUE, infinity = TRUE), ...)
{
    .Call("R_LapackPP_lu", x, norm.comp, PACKAGE="Matrix")
}
