.packageName <- "evd"
"rbvlog"<-
# Uses Algorithm 1.1 in Stephenson(2003)
function(n, dep, mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    sim <- .C("rbvlog_shi",
               as.integer(n), as.double(dep), sim = double(2*n),
               PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(1/sim, list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvalog"<-
# Uses Algorithm 1.2 in Stephenson(2003)
function(n, dep, asy = c(1,1), mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
       dep > 1) stop("invalid argument for `dep'")
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    if(dep == 1 || any(asy == 0)) {
        asy <- c(0,0)
        dep <- 1
    }
    sim <- .C("rbvalog_shi",
              as.integer(n), as.double(dep), as.double(asy),
              sim = double(2*n), PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(1/sim, list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvhr" <-
function(n, dep, mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    sim <- .C("rbvhr",
        as.integer(n), as.double(dep), sim = runif(2*n),
        PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(-log(sim), list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvneglog"<- 
function(n, dep, mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    sim <- .C("rbvneglog",
        as.integer(n), as.double(dep), sim = runif(2*n),
        PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(-log(sim), list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvaneglog"<- 
function(n, dep, asy = c(1,1), mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    sim <- .C("rbvaneglog",
        as.integer(n), as.double(dep), as.double(asy), sim = runif(2*n),
        PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(-log(sim), list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvbilog"<- 
function(n, alpha, beta, mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0) || any(c(alpha,beta) >= 1))
        stop("`alpha' and `beta' must be in the open interval (0,1)")
    sim <- .C("rbvbilog",
        as.integer(n), as.double(alpha), as.double(beta), sim = runif(2*n),
        PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(-log(sim), list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvnegbilog"<- 
function(n, alpha, beta, mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    sim <- .C("rbvnegbilog",
        as.integer(n), as.double(alpha), as.double(beta), sim = runif(2*n),
        PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(-log(sim), list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvct" <-
function(n, alpha, beta, mar1 = c(0,1,0), mar2 = mar1)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    sim <- .C("rbvct",
        as.integer(n), as.double(alpha), as.double(beta), sim = runif(2*n),
        PACKAGE = "evd")$sim
    sim <- matrix(sim, nrow = n, ncol = 2, byrow = TRUE)
    mtransform(-log(sim), list(mar1, mar2), inv = TRUE, drp = TRUE)
}

"rbvevd" <-
function(n, dep, asy = c(1,1), alpha, beta, model = c("log", "alog",
    "hr", "neglog", "aneglog", "bilog", "negbilog", "ct"),
    mar1 = c(0,1,0), mar2 = mar1)
{
  model <- match.arg(model)
  m1 <- c("bilog", "negbilog", "ct")
  m2 <- c(m1, "log", "hr", "neglog")
  m3 <- c("log", "alog", "hr", "neglog", "aneglog")
  if((model %in% m1) && !missing(dep))
    warning("ignoring `dep' argument")
  if((model %in% m2) && !missing(asy))
    warning("ignoring `asy' argument")
  if((model %in% m3) && !missing(alpha))
    warning("ignoring `alpha' argument")
  if((model %in% m3) && !missing(beta))
    warning("ignoring `beta' argument")
    
  switch(model,
    log = rbvlog(n = n, dep = dep, mar1 = mar1, mar2 = mar2),
    alog = rbvalog(n = n, dep = dep, asy = asy, mar1 = mar1, mar2 = mar2),
    hr = rbvhr(n = n, dep = dep, mar1 = mar1, mar2 = mar2),
    neglog = rbvneglog(n = n, dep = dep, mar1 = mar1, mar2 = mar2),
    aneglog = rbvaneglog(n = n, dep = dep, asy = asy, mar1 = mar1,
      mar2 = mar2),
    bilog = rbvbilog(n = n, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2),
    negbilog = rbvnegbilog(n = n, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2),
    ct = rbvct(n = n, alpha = alpha, beta = beta, mar1 = mar1, mar2 = mar2)) 
}

"evmc" <-
function(n, dep, asy = c(1,1), alpha, beta, model = c("log", "alog",
    "hr", "neglog", "aneglog", "bilog", "negbilog", "ct"),
    margins = c("uniform","exponential","frechet","gumbel"))
{
  model <- match.arg(model)
  m1 <- c("bilog", "negbilog", "ct")
  m2 <- c(m1, c("log", "hr", "neglog"))
  m3 <- c("log", "alog", "hr", "neglog", "aneglog")
  if((model %in% m1) && !missing(dep))
    warning("ignoring `dep' argument")
  if((model %in% m2) && !missing(asy))
    warning("ignoring `asy' argument")
  if((model %in% m3) && !missing(alpha))
    warning("ignoring `alpha' argument")
  if((model %in% m3) && !missing(beta))
    warning("ignoring `beta' argument")

  nn <- as.integer(1)
  if(!(model %in% m1)) {
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if((model %in% c("log", "alog")) && dep > 1)
        stop("`dep' must be in the interval (0,1]")
    dep <- as.double(dep)
  }
  if(!(model %in% m2)) {
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    if(model == "alog" && (dep == 1 || any(asy == 0))) {
        asy <- c(0,0)
        dep <- 1
    }
    asy <- as.double(asy[c(2,1)])
  }
  if(!(model %in% m3)) {
    if(length(alpha) != 1 || mode(alpha) != "numeric" || alpha <= 0)
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric" || beta <= 0)
        stop("invalid argument for `beta'")
    if(model == "bilog" && any(c(alpha,beta) >= 1))
        stop("`alpha' and `beta' must be in the open interval (0,1)")
    alpha <- as.double(beta)
    beta <- as.double(alpha)
  } 
    
  evmc <- runif(n)
  for(i in 2:n) {
    evmc[c(i,i-1)] <- switch(model,
      log = .C("rbvlog", nn, dep, sim = evmc[c(i,i-1)], PACKAGE = "evd")$sim,
      alog = .C("rbvalog", nn, dep, asy, sim = evmc[c(i,i-1)],
        PACKAGE = "evd")$sim,
      hr = .C("rbvhr", nn, dep, sim = evmc[c(i,i-1)], PACKAGE = "evd")$sim,
      neglog = .C("rbvneglog", nn, dep, sim = evmc[c(i,i-1)],
        PACKAGE = "evd")$sim,
      aneglog = .C("rbvaneglog", nn, dep, asy, sim = evmc[c(i,i-1)],
        PACKAGE = "evd")$sim,
      bilog = .C("rbvbilog", nn, alpha, beta, sim = evmc[c(i,i-1)],
        PACKAGE = "evd")$sim,
      negbilog = .C("rbvnegbilog", nn, alpha, beta, sim = evmc[c(i,i-1)],
        PACKAGE = "evd")$sim,
      ct = .C("rbvct", nn, alpha, beta, sim = evmc[c(i,i-1)],
        PACKAGE = "evd")$sim)
  }

  switch(match.arg(margins),
    frechet = -1/log(evmc), uniform = evmc,
    exponential = -log(evmc), gumbel = -log(-log(evmc))) 
}

"pbvlog"<- 
function(q, dep, mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    v <- apply(q^(1/dep),1,sum)^dep
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvalog"<- 
function(q, dep, asy = c(1,1), mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    asy <- rep(asy,rep(nrow(q),2))
    v <- apply((asy*q)^(1/dep),1,sum)^dep + apply((1-asy)*q,1,sum)
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvhr" <-
function(q, dep, mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    fn <- function(x1,x2) x1*pnorm(1/dep + dep * log(x1/x2) / 2)
    v <- fn(q[,1],q[,2]) + fn(q[,2],q[,1])
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvneglog"<- 
function(q, dep, mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    v <- apply(q,1,sum) - apply(q^(-dep),1,sum)^(-1/dep)
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvaneglog"<- 
function(q, dep, asy = c(1,1), mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    asy <- rep(asy,rep(nrow(q),2))
    v <- apply(q,1,sum) - apply((asy*q)^(-dep),1,sum)^(-1/dep)
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvbilog"<- 
function(q, alpha, beta, mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0) || any(c(alpha,beta) >= 1))
        stop("`alpha' and `beta' must be in the open interval (0,1)")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    gma <- numeric(nrow(q))
    for(i in 1:nrow(q)) {
        gmafn <- function(x)
            (1-alpha) * q[i,1] * (1-x)^beta - (1-beta) * q[i,2] * x^alpha
        if(any(is.na(q[i,]))) gma[i] <- NA
        else if(any(is.infinite(q[i,]))) gma[i] <- 0.5
        else if(q[i,1] == 0) gma[i] <- 0
        else if(q[i,2] == 0) gma[i] <- 1
        else gma[i] <- uniroot(gmafn, lower = 0, upper = 1,
                               tol = .Machine$double.eps^0.5)$root
    }
    v <- q[,1] * gma^(1-alpha) + q[,2] * (1 - gma)^(1-beta)
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvnegbilog"<- 
function(q, alpha, beta, mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    gma <- numeric(nrow(q))
    for(i in 1:nrow(q)) {
        gmafn <- function(x)
            (1+alpha) * q[i,1] * x^alpha - (1+beta) * q[i,2] * (1-x)^beta
        if(any(is.na(q[i,]))) gma[i] <- NA
        else if(any(is.infinite(q[i,]))) gma[i] <- Inf
        else if(q[i,1] == 0) gma[i] <- 1
        else if(q[i,2] == 0) gma[i] <- 0
        else gma[i] <- uniroot(gmafn, lower = 0, upper = 1,
                               tol = .Machine$double.eps^0.5)$root
    }
    v <- q[,1] + q[,2] - q[,1] * gma^(1+alpha) - q[,2] * (1 - gma)^(1+beta)
    v[is.infinite(gma)] <- Inf
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvct" <-
function(q, alpha, beta, mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    if(is.null(dim(q))) dim(q) <- c(1,2)
    q <- mtransform(q, list(mar1, mar2))
    u <- (alpha * q[,2]) / (alpha * q[,2] + beta * q[,1])  
    v <- q[,2] * pbeta(u, shape1 = alpha, shape2 = beta + 1) +
      q[,1] * pbeta(u, shape1 = alpha + 1, shape2 = beta, lower.tail = FALSE)
    v[is.infinite(q[,1]) || is.infinite(q[,2])] <- Inf
    v[(q[,1] + q[,2]) == 0] <- 0
    pp <- exp(-v)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pbvevd" <-
function(q, dep, asy = c(1,1), alpha, beta, model = c("log", "alog",
    "hr", "neglog", "aneglog", "bilog", "negbilog", "ct"),
    mar1 = c(0,1,0), mar2 = mar1, lower.tail = TRUE)
{
  model <- match.arg(model)
  m1 <- c("bilog", "negbilog", "ct")
  m2 <- c(m1, "log", "hr", "neglog")
  m3 <- c("log", "alog", "hr", "neglog", "aneglog")
  if((model %in% m1) && !missing(dep))
    warning("ignoring `dep' argument")
  if((model %in% m2) && !missing(asy))
    warning("ignoring `asy' argument")
  if((model %in% m3) && !missing(alpha))
    warning("ignoring `alpha' argument")
  if((model %in% m3) && !missing(beta))
    warning("ignoring `beta' argument")
    
  switch(model,
    log = pbvlog(q = q, dep = dep, mar1 = mar1, mar2 = mar2,
      lower.tail = lower.tail),
    alog = pbvalog(q = q, dep = dep, asy = asy, mar1 = mar1, mar2 = mar2,
      lower.tail = lower.tail),
    hr = pbvhr(q = q, dep = dep, mar1 = mar1, mar2 = mar2,
      lower.tail = lower.tail),
    neglog = pbvneglog(q = q, dep = dep, mar1 = mar1, mar2 = mar2,
      lower.tail = lower.tail),
    aneglog = pbvaneglog(q = q, dep = dep, asy = asy, mar1 = mar1,
      mar2 = mar2, lower.tail = lower.tail),
    bilog = pbvbilog(q = q, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2, lower.tail = lower.tail),
    negbilog = pbvnegbilog(q = q, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2, lower.tail = lower.tail),
    ct = pbvct(q = q, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2, lower.tail = lower.tail)) 
}

"abvlog"<- 
function(x = 0.5, dep, plot = FALSE, add = FALSE, lty = 1, lwd = 1, col = 1,
         blty = 3, xlim = c(0,1), ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(plot || add) x <- seq(0, 1, length = 100)
    idep <- 1/dep
    a <- (x^idep + (1-x)^idep)^dep
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)  
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvalog"<- 
function(x = 0.5, dep, asy = c(1,1), plot = FALSE, add = FALSE,
         lty = 1, lwd = 1, col = 1, blty = 3, xlim = c(0,1),
         ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    if(plot || add) x <- seq(0, 1, length = 100)
    idep <- 1/dep
    a <- ((asy[1]*x)^idep + (asy[2]*(1-x))^idep)^dep +
        (1-asy[1])*x + (1-asy[2])*(1-x)    
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...) 
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvhr" <-
function(x = 0.5, dep, plot = FALSE, add = FALSE, lty = 1, lwd = 1, col = 1,
         blty = 3, xlim = c(0,1), ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(plot || add) x <- seq(0, 1, length = 100)
    fn <- function(z) z*pnorm(1/dep + dep * log(z/(1-z)) / 2)
    a <- fn(x) + fn(1-x)
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)  
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvneglog"<- 
function(x = 0.5, dep, plot = FALSE, add = FALSE, lty = 1, lwd = 1, col = 1,
         blty = 3, xlim = c(0,1), ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")  
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(plot || add) x <- seq(0, 1, length = 100)
    a <- 1 - (x^(-dep) + (1-x)^(-dep))^(-1/dep)
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...) 
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvaneglog"<- 
function(x = 0.5, dep, asy = c(1,1), plot = FALSE, add = FALSE,
         lty = 1, lwd = 1, col = 1, blty = 3, xlim = c(0,1),
         ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(plot || add) x <- seq(0, 1, length = 100)
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    a <- 1 - ((asy[1]*x)^(-dep) + (asy[2]*(1-x))^(-dep))^(-1/dep)
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)  
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvbilog"<- 
function(x = 0.5, alpha, beta, plot = FALSE, add = FALSE,
         lty = 1, lwd = 1, col = 1, blty = 3, xlim = c(0,1),
         ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0) || any(c(alpha,beta) >= 1))
        stop("`alpha' and `beta' must be in the open interval (0,1)")
    if(plot || add) x <- seq(0, 1, length = 100)
    gma <- numeric(length(x))
    for(i in 1:length(x)) {
        gmafn <- function(z)
            (1-alpha) * x[i] * (1-z)^beta - (1-beta) * (1-x[i]) * z^alpha
        if(is.na(x[i])) gma[i] <- NA
        else if(x[i] == 0) gma[i] <- 0
        else if(x[i] == 1) gma[i] <- 1
        else gma[i] <- uniroot(gmafn, lower = 0, upper = 1,
                               tol = .Machine$double.eps^0.5)$root
    }
    a <- x * gma^(1-alpha) + (1-x) * (1 - gma)^(1-beta)
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)  
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvnegbilog"<- 
function(x = 0.5, alpha, beta, plot = FALSE, add = FALSE,
         lty = 1, lwd = 1, col = 1, blty = 3, xlim = c(0,1),
         ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    if(plot || add) x <- seq(0, 1, length = 100)
    gma <- numeric(length(x))
    for(i in 1:length(x)) {
        gmafn <- function(z)
            (1+alpha) * x[i] * z^alpha - (1+beta) * (1-x[i]) * (1-z)^beta
        if(is.na(x[i])) gma[i] <- NA
        else if(x[i] == 0) gma[i] <- 1
        else if(x[i] == 1) gma[i] <- 0
        else gma[i] <- uniroot(gmafn, lower = 0, upper = 1,
                               tol = .Machine$double.eps^0.5)$root
    }
    a <- 1 - x * gma^(1+alpha) - (1-x) * (1 - gma)^(1+beta)
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)  
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvct" <-
function(x = 0.5, alpha, beta, plot = FALSE, add = FALSE,
         lty = 1, lwd = 1, col = 1, blty = 3, xlim = c(0,1),
         ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0,na.rm=TRUE) || any(x > 1,na.rm=TRUE))
        stop("invalid argument for `x'")
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    if(plot || add) x <- seq(0, 1, length = 100)
    u <- (alpha * (1-x)) / (alpha * (1-x) + beta * x)
    a <- (1-x) * pbeta(u, shape1 = alpha, shape2 = beta + 1) +
      x * pbeta(u, shape1 = alpha + 1, shape2 = beta, lower.tail = FALSE)
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)  
        return(invisible(list(x = x, y = a)))
    }
    a
}

"abvpar" <-
function(x = 0.5, dep, asy = c(1,1), alpha, beta, model = c("log", "alog",
    "hr", "neglog", "aneglog", "bilog", "negbilog", "ct"),
     plot = FALSE, add = FALSE, lty = 1, lwd = 1, col = 1, blty = 3,
     xlim = c(0,1), ylim = c(0.5,1), xlab = "", ylab = "", ...)
{
  model <- match.arg(model)
  m1 <- c("bilog", "negbilog", "ct")
  m2 <- c(m1, "log", "hr", "neglog")
  m3 <- c("log", "alog", "hr", "neglog", "aneglog")
  if((model %in% m1) && !missing(dep))
    warning("ignoring `dep' argument")
  if((model %in% m2) && !missing(asy))
    warning("ignoring `asy' argument")
  if((model %in% m3) && !missing(alpha))
    warning("ignoring `alpha' argument")
  if((model %in% m3) && !missing(beta))
    warning("ignoring `beta' argument")
    
  switch(model,
    log = abvlog(x = x, dep = dep, plot = plot, add = add, lty = lty,
      lwd = lwd, col = col, blty = blty, xlim = xlim, ylim = ylim,
      xlab = xlab, ylab = ylab, ...),
    alog = abvalog(x = x, dep = dep, asy = asy, plot = plot, add = add,
      lty = lty, lwd = lwd, col = col, blty = blty, xlim = xlim, ylim = ylim,
      xlab = xlab, ylab = ylab, ...),
    hr = abvhr(x = x, dep = dep, plot = plot, add = add, lty = lty,
      lwd = lwd, col = col, blty = blty, xlim = xlim, ylim = ylim,
      xlab = xlab, ylab = ylab, ...),
    neglog = abvneglog(x = x, dep = dep, plot = plot, add = add, lty = lty,
      lwd = lwd, col = col, blty = blty, xlim = xlim, ylim = ylim,
      xlab = xlab, ylab = ylab, ...),
    aneglog = abvaneglog(x = x, dep = dep, asy = asy, plot = plot, add = add,
      lty = lty, lwd = lwd, col = col, blty = blty, xlim = xlim, ylim = ylim,
      xlab = xlab, ylab = ylab, ...),
    bilog = abvbilog(x = x, alpha = alpha, beta = beta, plot = plot,
      add = add, lty = lty, lwd = lwd, col = col, blty = blty, xlim = xlim,
      ylim = ylim, xlab = xlab, ylab = ylab, ...),
    negbilog = abvnegbilog(x = x, alpha = alpha, beta = beta, plot = plot,
      add = add, lty = lty, lwd = lwd, col = col, blty = blty, xlim = xlim,
      ylim = ylim, xlab = xlab, ylab = ylab, ...),
    ct = abvct(x = x, alpha = alpha, beta = beta, plot = plot, add = add,
      lty = lty, lwd = lwd, col = col, blty = blty, xlim = xlim, ylim = ylim,
      xlab = xlab, ylab = ylab, ...)) 
}

"abvnonpar"<- 
function(x = 0.5, data, nsloc1 = NULL, nsloc2 = NULL,
         method = c("cfg","pickands","deheuvels","hall","tdo"), convex = FALSE,
         wf = function(t) t, kmar = NULL, plot = FALSE, add = FALSE,
         lty = 1, lwd = 1, col = 1, blty = 3, xlim = c(0,1), ylim = c(0.5,1),
         xlab = "", ylab = "", ...)
{
    if(mode(x) != "numeric" || any(x < 0, na.rm=TRUE) ||
       any(x > 1, na.rm=TRUE)) stop("invalid argument for `x'")
    if(is.null(kmar)) {
        if(!is.null(nsloc1)) {
            nsloc1 <- nsloc.transform(data, nsloc1)
            nslocmat1 <- cbind(1,as.matrix(nsloc1))
        }
        if(!is.null(nsloc2)) {
            nsloc2 <- nsloc.transform(data, nsloc2)
            nslocmat2 <- cbind(1,as.matrix(nsloc2))
        }
        # Transform to exponential margins
        mle.m1 <- fgev(data[,1], nsloc = nsloc1, std.err = FALSE)$estimate
        loc.mle.m1 <- mle.m1[grep("^loc", names(mle.m1))]
        if(is.null(nsloc1)) loc.mle.m1 <- rep(loc.mle.m1, nrow(data))
        else loc.mle.m1 <- nslocmat1 %*% loc.mle.m1
        mle.m1 <- cbind(loc.mle.m1, mle.m1["scale"], mle.m1["shape"])
        mle.m2 <- fgev(data[,2], nsloc = nsloc2, std.err = FALSE)$estimate
        loc.mle.m2 <- mle.m2[grep("^loc", names(mle.m2))]
        if(is.null(nsloc2)) loc.mle.m2 <- rep(loc.mle.m2, nrow(data))
        else loc.mle.m2 <- nslocmat2 %*% loc.mle.m2
        mle.m2 <- cbind(loc.mle.m2, mle.m2["scale"], mle.m2["shape"])
        data <- mtransform(data, list(mle.m1, mle.m2))       
        # End transform
    }
    else {
        if(length(kmar) != 3 || mode(kmar) != "numeric")
            stop("`kmar' should be a numeric vector of length three")
        if(!is.null(nsloc1) || !is.null(nsloc2))
            warning("ignoring `nsloc1' and `nsloc2' arguments")
        data <- mtransform(data, kmar)
    }
    data <- na.omit(data)
    if(plot || add) x <- seq(0, 1, length = 100)
    method <- match.arg(method)
    mpmin <- function(a,b) {
      a[a > b] <- b[a > b]
      a
    }
    nn <- nrow(data)

    if(method == "pickands") {
        if(!convex) {
            a <- numeric(length(x))
            for(i in 1:length(x))
                a[i] <- sum(mpmin(data[,1]/x[i], data[,2]/(1-x[i])))
            a <- nn / a
            a <- pmin(1, pmax(a, x, 1-x))
        }
        else {
            x2 <- seq(0, 1, length = 250)
            a <- numeric(250)
            for(i in 1:250)
                a[i] <- sum(mpmin(data[,1]/x2[i], data[,2]/(1-x2[i])))
            a <- nn / a
            a <- pmin(1, pmax(a, x2, 1-x2))
            inch <- chull(x2, a)
            a <- a[inch] ; x2 <- x2[inch]
            a <- approx(x2, a, xout = x, method="linear")$y
        }
    } 
    if(method == "deheuvels") {
        if(!convex) {
            a <- numeric(length(x))
            for(i in 1:length(x))
                a[i] <- sum(mpmin(data[,1]/x[i], data[,2]/(1-x[i])))
            a <- nn / (a - x * sum(data[,1]) - (1-x) * sum(data[,2]) + nn)
            a <- pmin(1, pmax(a, x, 1-x))
        }
        else {
            x2 <- seq(0, 1, length = 250)
            a <- numeric(250)
            for(i in 1:250)
                a[i] <- sum(mpmin(data[,1]/x2[i], data[,2]/(1-x2[i]))) 
            a <- nn / (a - x2 * sum(data[,1]) - (1-x2) * sum(data[,2]) + nn)
            a <- pmin(1, pmax(a, x2, 1-x2))
            inch <- chull(x2, a)
            a <- a[inch] ; x2 <- x2[inch]
            a <- approx(x2, a, xout = x, method="linear")$y
        }
    }
    if(method == "cfg") {
        zvec <- sort(data[,1] / (data[,1] + data[,2]))
        if(any(table(zvec) > 1)) zvec <- jitter(zvec)
        zratio <- log(zvec) - log(1-zvec)
        qvec <- exp(cumsum(zratio) / nn)
        if(!convex) {
            step.pos <- as.numeric(cut(x, breaks = c(-0.1, zvec, 1))) - 1
            step.pos.r <- step.pos / nn
            a <- x^step.pos.r * (1-x)^(1 - step.pos.r) * qvec[nn]^wf(x) /
              c(rep(1, sum(step.pos == 0)), qvec[step.pos])
            a <- pmin(1, pmax(a, x, 1-x))
        }
        else {
            x2 <- seq(0, 1, length = 250)
            step.pos <- as.numeric(cut(x2, breaks = c(-0.1, zvec, 1))) - 1
            step.pos.r <- step.pos / nn
            a <- x2^step.pos.r * (1-x2)^(1 - step.pos.r) * qvec[nn]^wf(x2) /
              c(rep(1, sum(step.pos == 0)), qvec[step.pos])
            a <- pmin(1, pmax(a, x2, 1-x2))
            inch <- chull(x2, a)
            a <- a[inch] ; x2 <- x2[inch]
            a <- approx(x2, a, xout = x, method="linear")$y
        }
    }
    if(method == "tdo") {
        if(!convex) {
            a <- numeric(length(x))
            for(i in 1:length(x))
                a[i] <- sum(mpmin(x[i]/(1 + nn*data[,1]),
                                 (1-x[i])/(1 + nn*data[,2])))
            a <- 1 - a/(1 + log(nn))
            a <- pmin(1, pmax(a, x, 1-x))
        }
        else {
            x2 <- seq(0, 1, length = 250)
            a <- numeric(250)
            for(i in 1:250)
                a[i] <- sum(mpmin(x2[i]/(1 + nn*data[,1]),
                                 (1-x2[i])/(1 + nn*data[,2])))
            a <- 1 - a/(1 + log(nn))
            a <- pmin(1, pmax(a, x2, 1-x2))
            inch <- chull(x2, a)
            a <- a[inch] ; x2 <- x2[inch]
            a <- approx(x2, a, xout = x, method="linear")$y
        }
    } 
    if(method == "hall") {
        sum1 <- sum(data[,1])
        sum2 <- sum(data[,2])
        if(!convex) {
            a <- numeric(length(x))
            for(i in 1:length(x))
                a[i] <- sum(mpmin(data[,1]/(sum1 * x[i]),
                                 data[,2]/(sum2 * (1 - x[i]))))
            a <- 1/a
            a <- pmin(1, pmax(a, x, 1-x))
        }
        else {
            x2 <- seq(0, 1, length = 250)
            a <- numeric(250)
            for(i in 1:250)
                a[i] <- sum(mpmin(data[,1]/(sum1 * x2[i]),
                                 data[,2]/(sum2 * (1 - x2[i]))))
            a <- 1 / a
            a <- pmin(1, pmax(a, x2, 1-x2))
            inch <- chull(x2, a)
            a <- a[inch] ; x2 <- x2[inch]
            a <- approx(x2, a, xout = x, method="linear")$y
        }
    } 
    if(plot || add) {
        bvdepfn(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)  
        return(invisible(list(x = x, y = a)))
    }
    a
}

"dbvlog"<- 
function(x, dep, mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf    
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        idep <- 1/dep
        z <- apply(x^idep,1,sum)^dep
        lx <- log(x)
        .expr1 <- (idep+mar1[,3])*lx[,1] + (idep+mar2[,3])*lx[,2] -
            log(mar1[,2]*mar2[,2])
        d[!ext] <- .expr1 + (1-2*idep)*log(z) + log(idep-1+z) - z
    }
    if(!log) d <- exp(d)
    d
}

"dbvalog"<- 
function(x, dep, asy = c(1,1), mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        asy <- matrix(asy, ncol = 2, nrow = nrow(x), byrow = TRUE)
        idep <- 1/dep
        z <- apply((asy*x)^idep,1,sum)^dep
        v <- z + apply((1-asy)*x,1,sum)
        f1asy <- (idep)*log(asy)
        f2asy <- log(1-asy)
        lx <- log(x)
        fx <- (idep-1)*lx
        jac <- (1+mar1[,3])*lx[,1] + (1+mar2[,3])*lx[,2] -
            log(mar1[,2]*mar2[,2])
        .expr1 <- apply(f2asy,1,sum)
        .expr2 <- f2asy[,1] + f1asy[,2] + fx[,2]
        .expr3 <- f2asy[,2] + f1asy[,1] + fx[,1]
        .expr4 <- (1-idep)*log(z) + log(exp(.expr2)+exp(.expr3))
        .expr5 <- apply(cbind(f1asy,fx),1,sum) + (1-2*idep)*log(z) +
            log(idep-1+z)
        d[!ext] <- log(exp(.expr1)+exp(.expr4)+exp(.expr5))-v+jac
    }
    if(!log) d <- exp(d)
    d
}

"dbvhr" <-
function(x, dep, mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        fn <- function(x1, x2, nm = pnorm) x1 *
            nm(1/dep + dep * log(x1/x2) / 2)
        v <- fn(x[,1], x[,2]) + fn(x[,2], x[,1])
        .expr1 <- fn(x[,1], x[,2]) * fn(x[,2], x[,1]) +
            dep * fn(x[,1], x[,2], nm = dnorm) / 2
        lx <- log(x)
        jac <- mar1[,3]*lx[,1] + mar2[,3]*lx[,2] - log(mar1[,2]*mar2[,2])
        d[!ext] <- log(.expr1)+jac-v
    }
    if(!log) d <- exp(d)
    d    
}

"dbvneglog"<- 
function(x, dep, mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        idep <- 1/dep
        z <- apply(x^(-dep),1,sum)^(-idep)
        v <- apply(x,1,sum) - z
        lx <- log(x)
        fx <- (-dep-1)*lx
        jac <- (1+mar1[,3])*lx[,1] + (1+mar2[,3])*lx[,2] -
            log(mar1[,2]*mar2[,2])
        .expr1 <- (1+dep)*log(z) + log(exp(fx[,1])+exp(fx[,2]))
        .expr2 <- fx[,1] + fx[,2] + (1+2*dep)*log(z) + log(1+dep+z)
        d[!ext] <- log(1-exp(.expr1)+exp(.expr2))-v+jac
    }
    if(!log) d <- exp(d)
    d    
}

"dbvaneglog"<- 
function(x, dep, asy = c(1,1), mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0)
        stop("invalid argument for `dep'")
    if(length(asy) != 2 || mode(asy) != "numeric" || min(asy) < 0 ||
       max(asy) > 1) stop("invalid argument for `asy'")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        asy <- matrix(asy, ncol = 2, nrow = nrow(x), byrow = TRUE)
        idep <- 1/dep
        z <- apply((asy*x)^(-dep),1,sum)^(-idep)
        v <- apply(x,1,sum) - z
        fasy <- (-dep)*log(asy)
        lx <- log(x)
        fx <- (-dep-1)*lx
        jac <- (1+mar1[,3])*lx[,1] + (1+mar2[,3])*lx[,2] -
            log(mar1[,2]*mar2[,2])
        .expr1 <- fasy[,1] + fx[,1]
        .expr2 <- fasy[,2] + fx[,2]
        .expr3 <- (1+dep)*log(z) + log(exp(.expr1)+exp(.expr2))
        .expr4 <- apply(cbind(fasy,fx),1,sum) + (1+2*dep)*log(z) + log(1+dep+z)
        d[!ext] <- log(1-exp(.expr3)+exp(.expr4))-v+jac
    }
    if(!log) d <- exp(d)
    d
}

"dbvbilog"<- 
function(x, alpha, beta, mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0) || any(c(alpha,beta) >= 1))
        stop("`alpha' and `beta' must be in the open interval (0,1)")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        gma <- numeric(nrow(x))
        for(i in 1:nrow(x)) {
            gmafn <- function(z)
                (1-alpha) * x[i,1] * (1-z)^beta - (1-beta) * x[i,2] * z^alpha
            if(any(is.na(x[i,]))) gma[i] <- NA
            else gma[i] <- uniroot(gmafn, lower = 0, upper = 1,
                               tol = .Machine$double.eps^0.5)$root
        }
        v <- x[,1] * gma^(1-alpha) + x[,2] * (1 - gma)^(1-beta)
        lx <- log(x)
        jac <- (1+mar1[,3])*lx[,1] + (1+mar2[,3])*lx[,2] -
            log(mar1[,2]*mar2[,2])
        .expr1 <- exp((1-alpha)*log(gma) + (1-beta)*log(1-gma))
        .expr2 <- exp(log(1-alpha) + log(beta) + (beta - 1)*log(1-gma) +
            lx[,1]) + exp(log(1-beta) + log(alpha) + (alpha - 1)*log(gma) +
            lx[,2])
        d[!ext] <- log(.expr1 + (1-alpha)*(1-beta)/.expr2) - v + jac
    }
    if(!log) d <- exp(d)
    d   
}

"dbvnegbilog"<- 
function(x, alpha, beta, mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        gma <- numeric(nrow(x))
        for(i in 1:nrow(x)) {
            gmafn <- function(z)
                (1+alpha) * x[i,1] * z^alpha - (1+beta) * x[i,2] * (1-z)^beta
            if(any(is.na(x[i,]))) gma[i] <- NA
            else gma[i] <- uniroot(gmafn, lower = 0, upper = 1,
                               tol = .Machine$double.eps^0.5)$root
        }
        v <- x[,1] + x[,2] - x[,1] * gma^(1+alpha) - x[,2] * (1 - gma)^(1+beta)
        lx <- log(x)
        jac <- (1+mar1[,3])*lx[,1] + (1+mar2[,3])*lx[,2] -
            log(mar1[,2]*mar2[,2])
        .expr1 <- (1-gma^(1+alpha)) * (1 - (1-gma)^(1+beta))
        .expr2 <- exp(log(1+alpha) + log(1+beta) + alpha*log(gma) +
                      beta*log(1-gma))
        .expr3 <- exp(log(1+alpha) + log(alpha) + (alpha - 1)*log(gma) +
            lx[,1]) + exp(log(1+beta) + log(beta) + (beta - 1)*log(1-gma) +
            lx[,2])
        d[!ext] <- log(.expr1 + .expr2/.expr3) - v + jac
    }
    if(!log) d <- exp(d)
    d   
}

"dbvct"<- 
function(x, alpha, beta, mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
    if(length(alpha) != 1 || mode(alpha) != "numeric")
        stop("invalid argument for `alpha'")
    if(length(beta) != 1 || mode(beta) != "numeric")
        stop("invalid argument for `beta'")
    if(any(c(alpha,beta) <= 0))
        stop("`alpha' and `beta' must be non-negative")
    if(is.null(dim(x))) dim(x) <- c(1,2)
    mar1 <- matrix(t(mar1), nrow = nrow(x), ncol = 3, byrow = TRUE)
    mar2 <- matrix(t(mar2), nrow = nrow(x), ncol = 3, byrow = TRUE)
    d <- numeric(nrow(x))
    x <- mtransform(x, list(mar1, mar2))
    ext <- apply(x,1,function(z) any(z %in% c(0,Inf)))
    d[ext] <- -Inf
    if(any(!ext)) {
        x <- x[!ext, ,drop=FALSE]
        mar1 <- mar1[!ext, ,drop=FALSE]
        mar2 <- mar2[!ext, ,drop=FALSE]
        u <- (alpha * x[,2]) / (alpha * x[,2] + beta * x[,1]) 
        v <- x[,2] * pbeta(u, shape1 = alpha, shape2 = beta + 1) + x[,1] *
          pbeta(u, shape1 = alpha + 1, shape2 = beta, lower.tail = FALSE)
        lx <- log(x)
        jac <- (1+mar1[,3])*lx[,1] + (1+mar2[,3])*lx[,2] -
            log(mar1[,2]*mar2[,2])
        .c1 <- alpha * beta / (alpha + beta + 1)
        .expr1 <- pbeta(u, shape1 = alpha, shape2 = beta + 1) *
          pbeta(u, shape1 = alpha + 1, shape2 = beta, lower.tail = FALSE)
        .expr2 <- dbeta(u, shape1 = alpha + 1, shape2 = beta + 1) /
          (alpha * x[,2] + beta * x[,1]) 
        d[!ext] <- log(.expr1 + .c1 * .expr2) - v + jac
    }
    if(!log) d <- exp(d)
    d   
}

"dbvevd" <-
function(x, dep, asy = c(1,1), alpha, beta, model = c("log", "alog",
    "hr", "neglog", "aneglog", "bilog", "negbilog", "ct"),
    mar1 = c(0,1,0), mar2 = mar1, log = FALSE)
{
  model <- match.arg(model)
  m1 <- c("bilog", "negbilog", "ct")
  m2 <- c(m1, "log", "hr", "neglog")
  m3 <- c("log", "alog", "hr", "neglog", "aneglog")
  if((model %in% m1) && !missing(dep))
    warning("ignoring `dep' argument")
  if((model %in% m2) && !missing(asy))
    warning("ignoring `asy' argument")
  if((model %in% m3) && !missing(alpha))
    warning("ignoring `alpha' argument")
  if((model %in% m3) && !missing(beta))
    warning("ignoring `beta' argument")
    
  switch(model,
    log = dbvlog(x = x, dep = dep, mar1 = mar1, mar2 = mar2, log = log),
    alog = dbvalog(x = x, dep = dep, asy = asy, mar1 = mar1,
      mar2 = mar2, log = log),
    hr = dbvhr(x = x, dep = dep, mar1 = mar1, mar2 = mar2, log = log),
    neglog = dbvneglog(x = x, dep = dep, mar1 = mar1, mar2 = mar2, log = log),
    aneglog = dbvaneglog(x = x, dep = dep, asy = asy, mar1 = mar1,
      mar2 = mar2, log = log),
    bilog = dbvbilog(x = x, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2, log = log),
    negbilog = dbvnegbilog(x = x, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2, log = log),
    ct = dbvct(x = x, alpha = alpha, beta = beta, mar1 = mar1,
      mar2 = mar2, log = log)) 
}

"fbvlog"<- 
function(x, start, ..., nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlbvlog <- function(loc1, scale1, shape1, loc2, scale2, shape2, dep)
    {
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
        
        if(any(c(scale1,scale2) < 0.01) || dep < 0.1 || dep > 1)
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1, spx$n.m1, loc1[spx$na == 2], scale1,
                      shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2, spx$n.m2, loc2[spx$na == 1], scale2,
                      shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0   
        bvl <- .C("nlbvlog", spx$x1, spx$x2, spx$n, dep, loc1[spx$na == 0],
                  scale1, shape1, loc2[spx$na == 0], scale2, shape2,
                  dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    param <- c(param, "dep")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param,
                          loc.param1, loc.param2, model = "log") 
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:7)[c(!cscale, !cshape, TRUE)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvlog)[2:3],
           as.list(numeric(length(loc.param2))), formals(nlbvlog)[prind])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlbvlog) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvlog(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlbvlog(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
                 sym = FALSE, cmar = c(cloc, cscale, cshape), model = "log") 
}

"fbvalog"<- 
function(x, start, ..., sym = FALSE, nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{   
    nlbvalog <- function(loc1, scale1, shape1, loc2, scale2, shape2,
                          asy1, asy2, dep)
    {
        if(sym) asy2 <- asy1
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
          
        if(any(c(scale1,scale2) < 0.01) || any(c(dep,asy1,asy2) > 1) ||
           any(c(asy1,asy2) < 0.001) || dep < 0.1)
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
              ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1, spx$n.m1, loc1[spx$na == 2], scale1,
                shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2, spx$n.m2, loc2[spx$na == 1], scale2,
                shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0
        bvl <- .C("nlbvalog", spx$x1, spx$x2, spx$n, dep, asy1, asy2,
                loc1[spx$na == 0], scale1, shape1, loc2[spx$na == 0],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)  
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    if(!sym) param <- c(param, "asy1", "asy2", "dep")
    else param <- c(param, "asy1", "dep")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param, loc.param1,
      loc.param2, model = "alog")
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:9)[c(!cscale, !cshape, TRUE, !sym, TRUE)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvalog)[2:3],
      as.list(numeric(length(loc.param2))), formals(nlbvalog)[prind])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")
    formals(nlbvalog) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvalog(p, ...)
    if(l > 1) body(nllh) <- parse(text = paste("nlbvalog(", paste("p[",1:l,"]",
      collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
      sym = sym, cmar = c(cloc, cscale, cshape), model = "alog")
}

"fbvhr"<- 
function(x, start, ..., nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlbvhr <- function(loc1, scale1, shape1, loc2, scale2, shape2,
                       dep)
    {
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
        
        if(any(c(scale1,scale2) < 0.01) || dep < 0.2 || dep > 10)
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1, spx$n.m1, loc1[spx$na == 2], scale1,
                shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2, spx$n.m2, loc2[spx$na == 1], scale2,
                shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0
        bvl <- .C("nlbvhr", spx$x1, spx$x2, spx$n, dep, loc1[spx$na == 0],
                scale1, shape1, loc2[spx$na == 0], scale2, shape2,
                dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    param <- c(param, "dep")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param,
                          loc.param1, loc.param2, model = "hr") 
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:7)[c(!cscale, !cshape, TRUE)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvhr)[2:3],
           as.list(numeric(length(loc.param2))), formals(nlbvhr)[prind])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlbvhr) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvhr(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlbvhr(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
      sym = FALSE, cmar = c(cloc, cscale, cshape), model = "hr")
}

"fbvneglog"<- 
function(x, start, ..., nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlbvneglog <- function(loc1, scale1, shape1, loc2, scale2, shape2,
                           dep)
    {
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
        
        if(any(c(scale1,scale2) < 0.01) || dep < 0.05 || dep > 5)
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1, spx$n.m1, loc1[spx$na == 2], scale1,
                shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2, spx$n.m2, loc2[spx$na == 1], scale2,
                shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0
        bvl <- .C("nlbvneglog", spx$x1, spx$x2, spx$n, dep, loc1[spx$na == 0],
                  scale1, shape1, loc2[spx$na == 0], scale2, shape2,
                  dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    param <- c(param, "dep")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param,
                          loc.param1, loc.param2, model = "neglog") 
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:7)[c(!cscale, !cshape, TRUE)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvneglog)[2:3],
           as.list(numeric(length(loc.param2))), formals(nlbvneglog)[prind])
    names(f) <- param   
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlbvneglog) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvneglog(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlbvneglog(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
      sym = FALSE, cmar = c(cloc, cscale, cshape), model = "neglog")
}

"fbvaneglog"<- 
function(x, start, ..., sym = FALSE, nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlbvaneglog <- function(loc1, scale1, shape1, loc2, scale2, shape2,
                            asy1, asy2, dep)
    {
        if(sym) asy2 <- asy1
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
        
        if(any(c(scale1,scale2) < 0.01) || any(c(asy1,asy2) > 1) ||
           any(c(asy1,asy2) < 0.001) || dep < 0.05 || dep > 5)
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
              ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1, spx$n.m1, loc1[spx$na == 2],
                scale1, shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2, spx$n.m2, loc2[spx$na == 1],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0
        bvl <- .C("nlbvaneglog", spx$x1, spx$x2, spx$n, dep, asy1, asy2,
                loc1[spx$na == 0], scale1, shape1, loc2[spx$na == 0],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    if(!sym) param <- c(param, "asy1", "asy2", "dep")
    else param <- c(param, "asy1", "dep")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param,
      loc.param1, loc.param2, model = "aneglog") 
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:9)[c(!cscale, !cshape, TRUE, !sym, TRUE)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvaneglog)[2:3],
      as.list(numeric(length(loc.param2))), formals(nlbvaneglog)[prind])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")
    formals(nlbvaneglog) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvaneglog(p, ...)
    if(l > 1) body(nllh) <- parse(text = paste("nlbvaneglog(",
      paste("p[",1:l,"]", collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
      sym = sym, cmar = c(cloc, cscale, cshape), model = "aneglog")
}

"fbvbilog"<- 
function(x, start, ..., nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlbvbilog <- function(loc1, scale1, shape1, loc2, scale2, shape2,
                          alpha, beta)
    {
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
        
        if(any(c(scale1,scale2) < 0.01) || any(c(alpha,beta) < 0.1) ||
           any(c(alpha,beta) > 0.999))
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1,  spx$n.m1, loc1[spx$na == 2],
                scale1, shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2,  spx$n.m2, loc2[spx$na == 1],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0
        bvl <- .C("nlbvbilog", spx$x1, spx$x2, spx$n, alpha, beta,
                loc1[spx$na == 0], scale1, shape1, loc2[spx$na == 0],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    param <- c(param, "alpha", "beta")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param,
                          loc.param1, loc.param2, model = "bilog") 
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:8)[c(!cscale, !cshape, TRUE, TRUE)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvbilog)[2:3],
           as.list(numeric(length(loc.param2))), formals(nlbvbilog)[prind])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlbvbilog) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvbilog(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlbvbilog(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
      sym = FALSE, cmar = c(cloc, cscale, cshape), model = "bilog")
}

"fbvnegbilog"<- 
function(x, start, ..., nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlbvnegbilog <- function(loc1, scale1, shape1, loc2, scale2, shape2,
                             alpha, beta)
    {
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
        
        if(any(c(scale1,scale2) < 0.01) || any(c(alpha,beta) < 0.1) ||
           any(c(alpha,beta) > 20))
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1, spx$n.m1, loc1[spx$na == 2],
                scale1, shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2, spx$n.m2, loc2[spx$na == 1],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0
        bvl <- .C("nlbvnegbilog", spx$x1, spx$x2, spx$n, alpha, beta,
                  loc1[spx$na == 0], scale1, shape1, loc2[spx$na == 0],
                  scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    param <- c(param, "alpha", "beta")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param,
                          loc.param1, loc.param2, model = "negbilog") 
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:8)[c(!cscale, !cshape, TRUE, TRUE)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvnegbilog)[2:3],
           as.list(numeric(length(loc.param2))), formals(nlbvnegbilog)[prind])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlbvnegbilog) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvnegbilog(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlbvnegbilog(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values") 
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
      sym = FALSE, cmar = c(cloc, cscale, cshape), model = "negbilog")
}

"fbvct"<- 
function(x, start, ..., sym = FALSE, nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlbvct <- function(loc1, scale1, shape1, loc2, scale2, shape2,
                       alpha, beta)
    {
        if(sym) beta <- alpha
        if(cshape) shape2 <- shape1
        if(cscale) scale2 <- scale1
        
        if(any(c(scale1,scale2) < 0.01) || any(c(alpha,beta) < 0.001) ||
           any(c(alpha,beta) > 30))
            return(1e6)
        if(!is.null(nsloc1)) {
            ns <- numeric(length(loc.param1))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param1[i])
            loc1 <- drop(nslocmat1 %*% ns)
        }
        else loc1 <- rep(loc1, length.out = nrow(x))
        if(cloc) loc2 <- loc1 else {
          if(!is.null(nsloc2)) {
            ns <- numeric(length(loc.param2))
            for(i in 1:length(ns))
              ns[i] <- get(loc.param2[i])
            loc2 <- drop(nslocmat2 %*% ns)
          }
          else loc2 <- rep(loc2, length.out = nrow(x))
        }
        if(spx$n.m1)
            m1l <- .C("nlgev", spx$x.m1, spx$n.m1, loc1[spx$na == 2],
                scale1, shape1, dns = double(1), PACKAGE = "evd")$dns
        else m1l <- 0
        if(spx$n.m2)
            m2l <- .C("nlgev", spx$x.m2, spx$n.m2, loc2[spx$na == 1],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        else m2l <- 0
        bvl <- .C("nlbvct", spx$x1, spx$x2, spx$n, alpha, beta,
                loc1[spx$na == 0], scale1, shape1, loc2[spx$na == 0],
                scale2, shape2, dns = double(1), PACKAGE = "evd")$dns
        if(any(is.nan(c(m1l,m2l,bvl)))) {
            warning("NaN returned in likelihood")
            return(1e6)
        }
        if(any(c(m1l,m2l,bvl) == 1e6)) return(1e6)
        else return(m1l + m2l + bvl)
    }
    if(cloc && !identical(nsloc1, nsloc2))
      stop("nsloc1 and nsloc2 must be identical")
    if(!is.null(nsloc1)) {
        nsloc1 <- nsloc.transform(x, nsloc1)
        nslocmat1 <- cbind(1,as.matrix(nsloc1))
    }
    if(!is.null(nsloc2)) {
        nsloc2 <- nsloc.transform(x, nsloc2)
        nslocmat2 <- cbind(1,as.matrix(nsloc2))
    }
    loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
    loc.param2 <- paste("loc2", c("",names(nsloc2)), sep="")
    param <- c(loc.param1, "scale1", "shape1")
    if(!cloc) param <- c(param, loc.param2) else loc.param2 <- NULL
    if(!cscale) param <- c(param, "scale2")
    if(!cshape) param <- c(param, "shape2")
    if(!sym) param <- c(param, "alpha", "beta")
    else param <- c(param, "alpha")
    nmdots <- names(list(...))
    start <- bvstart.vals(x, start, nsloc1, nsloc2, nmdots, param,
      loc.param1, loc.param2, model = "ct") 
    spx <- sep.bvdata(x)
    nm <- names(start)
    l <- length(nm)
    fixed.param <- list(...)[nmdots %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    prind <- (5:8)[c(!cscale, !cshape, TRUE, !sym)]
    f <- c(as.list(numeric(length(loc.param1))), formals(nlbvct)[2:3],
      as.list(numeric(length(loc.param2))), formals(nlbvct)[prind])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")
    formals(nlbvct) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlbvct(p, ...)
    if(l > 1) body(nllh) <- parse(text = paste("nlbvct(",
      paste("p[",1:l,"]", collapse = ", "), ", ...)"))
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    bvpost.optim(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr,
      sym = sym, cmar = c(cloc, cscale, cshape), model = "ct")
}

"fbvevd" <-
function(x, model = c("log", "alog", "hr", "neglog", "aneglog", "bilog", "negbilog", "ct"), start, ..., sym = FALSE, nsloc1 = NULL, nsloc2 = NULL, cshape = cscale, cscale = cloc, cloc = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
  call <- match.call()
  model <- match.arg(model)
  if(sym && !(model %in% c("alog","aneglog","ct")))
    warning("Argument `sym' was ignored")
  
  ft <- switch(model,
    log = fbvlog(x=x, start=start, ..., nsloc1=nsloc1, nsloc2=nsloc2,
      cshape=cshape, cscale=cscale, cloc=cloc, std.err=std.err,
      dsm=dsm, corr=corr, method=method, warn.inf=warn.inf),
    alog = fbvalog(x=x, start=start, ..., sym=sym, nsloc1=nsloc1,
      nsloc2=nsloc2, cshape=cshape, cscale=cscale, cloc=cloc,
      std.err=std.err, dsm=dsm, corr=corr, method=method,
      warn.inf=warn.inf),
    hr = fbvhr(x=x, start=start, ..., nsloc1=nsloc1, nsloc2=nsloc2,
      cshape=cshape, cscale=cscale, cloc=cloc, std.err=std.err, dsm=dsm,
      corr=corr, method=method, warn.inf=warn.inf),
    neglog = fbvneglog(x=x, start=start, ..., nsloc1=nsloc1, nsloc2=nsloc2,
      cshape=cshape, cscale=cscale, cloc=cloc, std.err=std.err, dsm=dsm,
      corr=corr, method=method, warn.inf=warn.inf),
    aneglog = fbvaneglog(x=x, start=start, ..., sym=sym, nsloc1=nsloc1,
      nsloc2=nsloc2, cshape=cshape, cscale=cscale, cloc=cloc,
      std.err=std.err, dsm=dsm, corr=corr, method=method,
      warn.inf=warn.inf),
    bilog = fbvbilog(x=x, start=start, ..., nsloc1=nsloc1, nsloc2=nsloc2,
      cshape=cshape, cscale=cscale, cloc=cloc, std.err=std.err, dsm=dsm,
      corr=corr, method=method, warn.inf=warn.inf),
    negbilog = fbvnegbilog(x=x, start=start, ..., nsloc1=nsloc1,
      nsloc2=nsloc2, cshape=cshape, cscale=cscale, cloc=cloc,
      std.err=std.err, dsm=dsm, corr= corr, method=method,
      warn.inf=warn.inf),
    ct = fbvct(x=x, start=start, ..., sym=sym, nsloc1=nsloc1,
      nsloc2=nsloc2, cshape=cshape, cscale=cscale, cloc=cloc,
      std.err=std.err, dsm=dsm, corr=corr, method=method,
      warn.inf=warn.inf))

  structure(c(ft, call = call), class = c("bvevd","evd"))
}

"print.bvevd" <-  function(x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:", deparse(x$call), "\n")
    cat("Deviance:", deviance(x), "\n")
    cat("AIC:", AIC(x), "\n")
    cat("\nEstimates\n")
    print.default(format(fitted(x), digits = digits), print.gap = 2, 
        quote = FALSE)
    if(!is.null(std.errors(x))) {
      cat("\nStandard Errors\n")
      print.default(format(std.errors(x), digits = digits),
          print.gap = 2, quote = FALSE)
    }
    if(!is.null(x$corr)) {
      cat("\nCorrelations\n")
      print.default(format(x$corr, digits = digits), print.gap = 2, 
          quote = FALSE)
    }
    if(!is.null(x$dep.summary)) {
      cat("\nDependence Structure\n")
      cat("  Dependence One:", x$dep.summary[1], "\n")
      cat("  Dependence Two:", x$dep.summary[2], "\n")
      cat("  Asymmetry:", x$dep.summary[3], "\n")
    }
    cat("\nOptimization Information\n")
    cat("  Convergence:", x$convergence, "\n")
    cat("  Function Evaluations:", x$counts["function"], "\n")
    if(!is.na(x$counts["gradient"]))
        cat("  Gradient Evaluations:", x$counts["gradient"], "\n")
    if(!is.null(x$message)) cat("  Message:", x$message, "\n")
    cat("\n")
    invisible(x)
}

"plot.bvevd" <-  function(x, mar = 0, which = 1:4, main =
     c("Conditional Plot One", "Conditional Plot Two", "Density Plot",
       "Dependence Function"),
     ask = nb.fig < length(which) && dev.interactive(), ci = TRUE,
     jitter = FALSE, grid = 50, nplty = 2, blty = 3, method = "cfg",
     convex = FALSE, wf = function(t) t, ...) 
{
    if (!inherits(x, "bvevd")) 
        stop("Use only with `bvevd' objects")
    nb.fig <- prod(par("mfcol"))
    if(mar == 1 || mar == 2) {
        indx <- paste(c("loc","scale","shape"), as.character(mar), sep="")
        tdata <- na.omit(x$tdata[, mar])
        n <- length(tdata)
        param <- x$param[indx]
        names(param) <- c("loc","scale","shape")
        gev.mar <- structure(list(param = param, tdata = tdata, n = n,
           loc = param["loc"]), class = c("gev", "uvevd", "evd"))
        if(missing(which)) which <- 1:4
        if(missing(main)) main <- c("Probability Plot", "Quantile Plot",
           "Density Plot", "Return Level Plot")
        plot(gev.mar, which = which, main = main, ask = ask, ci = ci,
             jitter = jitter, ...)
        return(invisible(x))
    }
    if (!is.numeric(which) || any(which < 1) || any(which > 4)) 
        stop("`which' must be in 1:4")
    show <- rep(FALSE, 4)
    show[which] <- TRUE
    if (ask) {
        op <- par(ask = TRUE)
        on.exit(par(op))
    }
    if (show[1]) {
        bvcpp(x, mar = 1, ci = ci, main = main[1], xlim = c(0,1),
              ylim = c(0,1), ...)
    }
    if (show[2]) {
        bvcpp(x, mar = 2, ci = ci, main = main[2], xlim = c(0,1),
              ylim = c(0,1), ...)
    }
    if (show[3]) {
        bvdens(x, jitter = jitter, grid = grid, main = main[3], ...)
    }
    if (show[4]) {
        bvdp(x, nplty = nplty, blty = blty, method = method,
             wf = wf, main = main[4], ...)
    }
    invisible(x)
} 

"bvcpp" <-  function(x, mar = 2, ci = TRUE, main = "Conditional Probability Plot", xlab = "Empirical", ylab = "Model", ...)
{ 
    data <- x$tdata
    mle.m1 <- x$param[c("loc1","scale1","shape1")]
    mle.m2 <- x$param[c("loc2","scale2","shape2")]
    data <- exp(-mtransform(data, list(mle.m1, mle.m2)))
    data <- na.omit(data)
    n <- nrow(data)
    ppx <- ppoints(n)
    if(x$model %in% c("log","hr","neglog"))
        probs <- ccop(data[,1], data[,2], mar = mar, dep = x$param["dep"],
                      model = x$model)
    if(x$model  %in% c("alog","aneglog"))
        probs <- ccop(data[,1], data[,2], mar = mar, dep = x$param["dep"],
                      asy = x$param[c("asy1","asy2")], model = x$model)
    if(x$model  %in% c("bilog","negbilog","ct"))
        probs <- ccop(data[,1], data[,2], mar = mar, alpha = x$param["alpha"],
                      beta = x$param["beta"], model = x$model)
    probs <- sort(probs)
    if(!ci) {
        plot(ppx, probs, main = main, xlab = xlab, ylab = ylab, ...)
        abline(0, 1)
    }
    else {
        samp <- runif(n*99)
        samp <- matrix(samp, n, 99)
        samp <- apply(samp, 2, sort)
        samp <- apply(samp, 1, sort)
        env <- t(samp[c(3,97),])
        matplot(ppx, cbind(probs, env), main = main, xlab = xlab,
                ylab = ylab, type = "pnn", pch = 4, ...)
        xyuser <- par("usr")
        smidge <- min(diff(c(xyuser[1], ppx, xyuser[2])))/2
        segments(ppx-smidge, env[,1], ppx+smidge, env[,1])
        segments(ppx-smidge, env[,2], ppx+smidge, env[,2])
        abline(0, 1)
    }
    invisible(list(x = ppx, y = probs))
}

"ccop" <- function(x1, x2, mar, dep, asy, alpha, beta, model)
{
    model <- match(model, c("log","alog","hr","neglog","aneglog",
                            "bilog","negbilog","ct"))
    if(model <= 5) alpha <- beta <- 1
    else dep <- 1
    if(model != 2 && model != 5) asy <- c(1,1)
    n <- length(x1)
    .C("ccop",
            as.double(x1), as.double(x2), as.integer(mar), as.double(dep),
            as.double(asy[1]), as.double(asy[2]), as.double(alpha),
            as.double(beta), as.integer(n), as.integer(model),
            ccop = double(n), PACKAGE = "evd")$ccop
}

"bvdens" <-  function(x, jitter = FALSE, grid = 50, main = "Density Plot", xlab = "", ylab = "", ...)
{
    xlimit <- range(x$tdata[,1], na.rm = TRUE)
    ylimit <- range(x$tdata[,2], na.rm = TRUE)
    xlimit[1] <- xlimit[1] - diff(xlimit) * 0.1
    xlimit[2] <- xlimit[2] + diff(xlimit) * 0.1
    ylimit[1] <- ylimit[1] - diff(ylimit) * 0.1
    ylimit[2] <- ylimit[2] + diff(ylimit) * 0.1
    xvec <- seq(xlimit[1], xlimit[2], length = grid)
    yvec <- seq(ylimit[1], ylimit[2], length = grid)
    xyvals <- expand.grid(xvec, yvec)
    mar1 <- x$param[c("loc1","scale1","shape1")]
    mar2 <- x$param[c("loc2","scale2","shape2")]
    if(x$model %in% c("log","hr","neglog"))
        dfunargs <- list(dep = x$param["dep"], mar1 = mar1, mar2 = mar2)
    if(x$model  %in% c("alog","aneglog"))
        dfunargs <- list(dep = x$param["dep"],
            asy = x$param[c("asy1","asy2")], mar1 = mar1, mar2 = mar2)
    if(x$model  %in% c("bilog","negbilog","ct"))
        dfunargs <- list(alpha = x$param["alpha"], beta = x$param["beta"],
            mar1 = mar1, mar2 = mar2)
    dfunargs <- c(list(x = xyvals, model = x$model), dfunargs)
    dens <- do.call("dbvevd", dfunargs)
    dens <- matrix(dens, nrow = grid, ncol = grid)
    contour(xvec, yvec, dens, main = main, xlab = xlab, ylab = ylab, ...)
    data <- na.omit(x$tdata)
    if(jitter) {
        data[,1] <- jitter(data[,1])
        data[,2] <- jitter(data[,2])
    }
    points(data, pch = 4)
    invisible(list(x = xyvals, y = dens))
}

"bvdp" <- function(x, method = "cfg", convex = FALSE, wf = function(t) t, add = FALSE, lty = 1, nplty = 2, blty = 3, main = "Dependence Function", xlab = "", ylab = "", ...)
{
    abvnonpar(data = x$data, nsloc1 = x$nsloc1, nsloc2 = x$nsloc2,
              method = method, convex = convex, wf = wf,
              plot = TRUE, lty = nplty, blty = blty, main = main,
              xlab = xlab, ylab = ylab, add = add, ...)
    if(x$model %in% c("log","hr","neglog"))
        afunargs <- list(dep = x$param["dep"])
    if(x$model  %in% c("alog","aneglog"))
        afunargs <- list(dep = x$param["dep"], asy = x$param[c("asy1","asy2")])
    if(x$model  %in% c("bilog","negbilog","ct"))
        afunargs <- list(alpha = x$param["alpha"], beta = x$param["beta"])
    afunargs <- c(list(add = TRUE, lty = lty, model = x$model), afunargs)
    do.call("abvpar", afunargs)
    invisible(x)
}

"mtransform"<- 
function(x, p, inv = FALSE, drp = FALSE)
{
    if(is.list(p)) {
      if(is.null(dim(x)) && length(x) != length(p))
        stop(paste("`p' must have", length(x), "elements"))
      if(!is.null(dim(x)) && ncol(x) != length(p))
        stop(paste("`p' must have", ncol(x), "elements"))
      if(is.null(dim(x))) dim(x) <- c(1, length(p))
      for(i in 1:length(p))
        x[,i] <- Recall(x[,i], p[[i]], inv = inv)
      if(ncol(x) == 1 || (nrow(x) == 1 && drp)) x <- drop(x)
      return(x)
    }
    if(is.null(dim(x))) dim(x) <- c(length(x), 1)
    p <- matrix(t(p), nrow = nrow(x), ncol = 3, byrow = TRUE)
    if(min(p[,2]) <= 0) stop("invalid marginal scale")
    gumind <- (p[,3] == 0)
    nzshapes <- p[!gumind,3]
    if(!inv) {
        x <- (x - p[,1])/p[,2]
        x[gumind, ] <- exp(-x[gumind, ])
        if(any(!gumind))
        x[!gumind, ] <- pmax(1 + nzshapes*x[!gumind, ], 0)^(-1/nzshapes)
    }
    else {
        x[gumind, ] <- p[gumind,1] - p[gumind,2] * log(x[gumind, ])
        x[!gumind, ] <- p[!gumind,1] + p[!gumind,2] *
          (x[!gumind, ]^(-nzshapes) - 1)/nzshapes
    }
    if(ncol(x) == 1 || (nrow(x) == 1 && drp)) x <- drop(x)
    x
}

"bvdepfn" <- 
function(x, a, add, lty, lwd, col, blty, xlab, ylab, xlim, ylim, ...)
{
    if(!add)  { 
        plot(x, a, type="n", xlab = xlab, ylab = ylab,
             xlim = xlim, ylim = ylim, ...) 
        polygon(c(0, 0.5, 1), c(1, 0.5, 1), lty = blty)  
    }
    lines(x, a, lty = lty, lwd = lwd, col = col)
}

na.vals <- function(x) {
    x <- cbind(is.na(x[,1]),2*is.na(x[,2]))
    drop(x %*% c(1,1))
}

"bvstart.vals" <- 
function(x, start, nsloc1, nsloc2, nmdots, param, loc.param1, loc.param2, model, obj = "bvevd", u = NULL)
{
  if(missing(start)) {
    start <- as.list(numeric(length(param)))
    names(start) <- param
    if(obj == "bvevd") {
      st1 <- as.list(fitted(fgev(x[,1], std.err = FALSE, nsloc = nsloc1)))
      st2 <- as.list(fitted(fgev(x[,2], std.err = FALSE, nsloc = nsloc2)))
    }
    if(obj == "bvpot") {
      st1 <- as.list(fitted(fpot(x[,1], u[1], std.err = FALSE)))
      st2 <- as.list(fitted(fpot(x[,2], u[2], std.err = FALSE)))
    }
    start[c(loc.param1, "scale1", "shape1")] <- st1
    tmp2 <- loc.param2
    if("scale2" %in% param) tmp2 <- c(tmp2, "scale2")
    if("shape2" %in% param) tmp2 <- c(tmp2, "shape2")
    tmp <- sub("2", "", tmp2)
    start[tmp2] <- st2[tmp]
    if(model == "log") start[["dep"]] <- 0.75
    if(model == "alog") {
        start[["asy1"]] <- 0.75
        if("asy2" %in% param) start[["asy2"]] <- 0.75 
        start[["dep"]] <- 0.65
    }
    if(model == "hr") start[["dep"]] <- 1
    if(model == "neglog") start[["dep"]] <- 0.6
    if(model == "aneglog") {
        start[["asy1"]] <- 0.75
        if("asy2" %in% param) start[["asy2"]] <- 0.75 
        start[["dep"]] <- 0.8
    }
    if(model == "bilog") start[["alpha"]] <- start[["beta"]] <- 0.75
    if(model == "negbilog") start[["alpha"]] <- start[["beta"]] <- 1/0.6
    if(model == "ct") {
      start[["alpha"]] <- 0.6
      if("beta" %in% param) start[["beta"]] <- 0.6 
    }
    start <- start[!(param %in% nmdots)]
  }
  if(any(!is.na(match(names(start),c("mar1","mar2","asy"))))) {
    if(("mar1" %in% names(start)) && (length(start$mar1) !=
      (2+length(loc.param1)))) stop("mar1 in `start' has incorrect length")
    if(("mar2" %in% names(start)) && (length(start$mar2) !=
      (2+length(loc.param2)))) stop("mar2 in `start' has incorrect length")
    if(("asy" %in% names(start)) && (length(start$asy) != 2))
      stop("asy in `start' should have length two")
    start <- unlist(start)
    names(start)[grep("mar1",names(start))] <- c(loc.param1,"scale1","shape1")
    names(start)[grep("mar2",names(start))] <- c(loc.param2,"scale2","shape2")
    start <- as.list(start)
  }
  if(!is.list(start)) 
    stop("`start' must be a named list")
  start
}

"sep.bvdata" <- 
function(x, obj = "bvevd", u = NULL, censored = TRUE)
{
    if(obj == "bvevd") {
      na <- na.vals(x)
      if(!any(na == 0))
        stop("`x' must have at least one complete observation")
      x.m1 <- as.double(x[na == 2, 1])
      n.m1 <- as.integer(length(x.m1))
      x.m2 <- as.double(x[na == 1, 2])
      n.m2 <- as.integer(length(x.m2))
      x.full <- x[na == 0, , drop = FALSE]
      x1 <- as.double(x.full[,1])
      x2 <- as.double(x.full[,2])
      n <- as.integer(nrow(x.full))
      spx <- list(x.m1 = x.m1, n.m1 = n.m1, x.m2 = x.m2, n.m2 = n.m2,
        x1 = x1, x2 = x2, n = n, na = na)
    }
    if(obj == "bvpot") {
      x1 <- x[,1]
      x2 <- x[,2]
      n <- length(x1)
      r1 <- r2 <- NULL
      iau1 <- (x1 > u[1]) & !is.na(x1)
      iau2 <- (x2 > u[2]) & !is.na(x2)
      nat <- c(sum(iau1), sum(iau2), sum(iau1 & iau2))
      lambda1 <- 1 - sum(!iau1) / n
      lambda2 <- 1 - sum(!iau2) / n
      lambda <- c(lambda1, lambda2)
      if(!censored) {
        x1[is.na(x1)] <- mean(x1[!iau1], na.rm = TRUE)
        x2[is.na(x2)] <- mean(x2[!iau2], na.rm = TRUE)
        r1 <- 1 - rank(x1)/n
        r2 <- 1 - rank(x2)/n
        r1[iau1] <- lambda1
        r2[iau2] <- lambda2
      }
      x1 <- x1 - u[1]
      x2 <- x2 - u[2]
      x1[!iau1] <- 0
      x2[!iau2] <- 0
      i0 <- iau1 | iau2
      x1 <- x1[i0] ; x2 <- x2[i0]
      if(!censored) {
       r1 <- r1[i0] ; r2 <- r2[i0]
      }
      nn <- length(x1)
      thdi <- as.logical(x1) + 2*as.logical(x2)
      spx <- list(x1 = x1, x2 = x2, nn = nn, n = n, thdi = thdi, lambda =
        lambda, r1 = r1, r2 = r2, nat = nat)
    }
    spx
}

"bvpost.optim" <- 
function(x, opt, nm, nsloc1, nsloc2, fixed.param, std.err, dsm, corr, sym, cmar, model)
{
    if (opt$convergence != 0) {
        warning(paste("optimization for", model, "may not have succeeded"))
        if(opt$convergence == 1) opt$convergence <- "iteration limit reached"
    }
    else opt$convergence <- "successful"
    if(std.err) {
        tol <- .Machine$double.eps^0.5
        var.cov <- qr(opt$hessian, tol = tol)
        if(var.cov$rank != ncol(var.cov$qr)) 
            stop(paste("observed information matrix for", model,
                       "is singular; use std.err = FALSE"))
        var.cov <- solve(var.cov, tol = tol)
        std.err <- diag(var.cov)
        if(any(std.err <= 0))
            stop(paste("observed information matrix for", model,
                       "is singular; use std.err = FALSE"))
        std.err <- sqrt(std.err)
        names(std.err) <- nm
        if(corr) {
            .mat <- diag(1/std.err, nrow = length(std.err))
            corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm,nm))
            diag(corr) <- rep(1, length(std.err))
        }
        else corr <- NULL
    }
    else std.err <- corr <- NULL
    fixed <- unlist(fixed.param)
    param <- c(opt$par, fixed)
    fixed2 <- NULL
    if(cmar[1]) {
      loc.param1 <- paste("loc1", c("",names(nsloc1)), sep="")
      fixed2 <- c(fixed2, param[loc.param1])
    }
    if(cmar[2]) fixed2 <- c(fixed2, param["scale1"])
    if(cmar[3]) fixed2 <- c(fixed2, param["shape1"])
    if(sym) {
      if(model %in% c("alog","aneglog")) fixed2 <- c(fixed2, param["asy1"])
      if(model == "ct") fixed2 <- c(fixed2, param["alpha"])
    }
    if(!is.null(fixed2)) {
      names(fixed2) <- sub("1", "2", names(fixed2))
      names(fixed2) <- sub("alpha", "beta", names(fixed2))
    }
    param <- c(param, fixed2)
    # Transform to stationarity
    x2 <- x
    if(!is.null(nsloc1)) {
        trend <- param[paste("loc1", names(nsloc1), sep="")]
        trend <- drop(as.matrix(nsloc1) %*% trend)
        x2[,1] <- x[,1] - trend
    }
    if(!is.null(nsloc2)) {
        trend <- param[paste("loc2", names(nsloc2), sep="")]
        trend <- drop(as.matrix(nsloc2) %*% trend)
        x2[,2] <- x[,2] - trend
    }
    # End transform
    # Dependence summary
    if(dsm) {
      dep.sum <- numeric(3)
      if(model %in% c("log", "hr", "neglog")) {
        dep <- param["dep"]
        dep.sum[1] <- 2*(1 - abvpar(dep = dep, model = model))
        dep.sum[2] <- 4 * integrate(function(x) 1-abvpar(x, dep = dep,
          model = model), 0, 1)$value
      }
      if(model %in% c("alog", "aneglog")) {
        dep <- param["dep"]
        asy <- param[c("asy1", "asy2")]
        dep.sum[1] <- 2*(1 - abvpar(dep = dep, asy = asy, model = model))
        dep.sum[2] <- 4 * integrate(function(x) 1-abvpar(x, dep = dep,
          asy = asy, model = model), 0, 1)$value
        dffn <- function(x) abvpar(x, dep = dep, asy = asy, model = model) -
          abvpar(x, dep = dep, asy = rev(asy), model = model)
        dep.sum[3] <- 4*integrate(dffn, 0, .5)$value / (3 - 2*sqrt(2))
      }
      if(model %in% c("bilog", "negbilog", "ct")) {
        alpha <- param["alpha"]
        beta <- param["beta"]
        dep.sum[1] <- 2*(1-abvpar(alpha = alpha, beta = beta, model = model))
        dep.sum[2] <- 4 * integrate(function(x) 1-abvpar(x, alpha = alpha,
          beta = beta, model = model), 0, 1)$value
        dffn <- function(x) abvpar(x, alpha = alpha, beta = beta, model =
          model) - abvpar(x, alpha = beta, beta = alpha, model = model)
        dep.sum[3] <- 4*integrate(dffn, 0, .5)$value / (3 - 2*sqrt(2))
      }
    }
    else dep.sum <- NULL
    # End dependence summary
    list(estimate = opt$par, std.err = std.err, fixed = fixed,
    fixed2 = fixed2, param = param, deviance = 2*opt$value,
    dep.summary = dep.sum, corr = corr, convergence = opt$convergence,
    counts = opt$counts, message = opt$message, data = x, tdata = x2,
    nsloc1 = nsloc1, nsloc2 = nsloc2, n = nrow(x), sym = sym, cmar =
    cmar, model = model)
}







################## bivariate threshold fitting routines #################

fbvpot <- function(x, threshold, model = c("log", "bilog", "alog", "neglog", "negbilog", "aneglog", "ct", "hr"), likelihood = c("censored","poisson"), start, ..., sym = FALSE, cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {
  call <- match.call()
  likelihood <- match.arg(likelihood)
  ft <- switch(likelihood,
    censored = fbvcpot(x = x, u = threshold, model = model, start = start, ...,
      sym = sym, cshape = cshape, cscale = cscale, std.err =
      std.err, dsm = dsm, corr = corr, method = method, warn.inf = warn.inf),
    poisson = fbvppot(x = x, u = threshold, model = model, start = start, ...,
      sym = sym, cshape = cshape, cscale = cscale, std.err =
      std.err, dsm = dsm, corr = corr, method = method, warn.inf = warn.inf))
  structure(c(ft, call = call), class = c("bvpot", "evd"))
}

fbvcpot <- function(x, u, model = c("log", "bilog", "alog", "neglog", "negbilog", "aneglog", "ct", "hr"), start, ..., sym = FALSE, cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {
  model <- match.arg(model)
  if(sym && !(model %in% c("alog","aneglog","ct")))
    warning("Argument `sym' was ignored")
  switch(model,
    log = fbvclog(x = x, u = u, start = start, ..., cshape = cshape,
      cscale = cscale, std.err = std.err, dsm = dsm,
      corr = corr, method = method, warn.inf = warn.inf),
    bilog = fbvcbilog(x = x, u = u, start = start, ..., cshape = cshape,
      cscale = cscale, std.err = std.err, dsm = dsm,
      corr = corr, method = method, warn.inf = warn.inf),
    alog = fbvcalog(x = x, u = u, start = start, ..., sym = sym,
      cshape = cshape, cscale = cscale, std.err = std.err,
      dsm = dsm, corr = corr, method = method, warn.inf = warn.inf),
    neglog = fbvcneglog(x = x, u = u, start = start, ..., cshape =
      cshape, cscale = cscale, std.err = std.err,
      dsm = dsm, corr = corr, method = method, warn.inf = warn.inf),
    negbilog = fbvcnegbilog(x = x, u = u, start = start, ..., cshape =
      cshape, cscale = cscale, std.err = std.err, dsm = dsm,
      corr = corr, method = method, warn.inf = warn.inf),
    aneglog = fbvcaneglog(x = x, u = u, start = start, ..., sym = sym,
      cshape = cshape, cscale = cscale, std.err = std.err,
      dsm = dsm, corr = corr, method = method, warn.inf = warn.inf),
    ct = fbvcct(x = x, u = u, start = start, ..., sym = sym, cshape =
      cshape, cscale = cscale, std.err = std.err, dsm = dsm,
      corr = corr, method = method, warn.inf = warn.inf),
    hr = fbvchr(x = x, u = u, start = start, ..., cshape = cshape,
      cscale = cscale, std.err = std.err, dsm = dsm, corr =
      corr, method = method, warn.inf = warn.inf))
}

fbvppot <- function(x, u, model = c("log", "bilog", "alog", "neglog", "negbilog", "aneglog", "ct", "hr"), start, ..., sym = FALSE, cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {
  model <- match.arg(model)
  if(model %in% c("alog","aneglog","hr"))
    stop("This model is not implemented for poisson likelihood")
  if(sym && (model != "ct"))
    warning("Argument `sym' was ignored")
  switch(model,
    log = fbvplog(x = x, u = u, start = start, ..., cshape = cshape,
      cscale = cscale, std.err = std.err, dsm = dsm,
      corr = corr, method = method, warn.inf = warn.inf),
    bilog = fbvpbilog(x = x, u = u, start = start, ..., cshape = cshape,
      cscale = cscale, std.err = std.err, dsm = dsm, corr =
      corr, method = method, warn.inf = warn.inf),
    neglog = fbvpneglog(x = x, u = u, start = start, ..., cshape =
      cshape, cscale = cscale, std.err = std.err,
      dsm = dsm, corr = corr, method = method, warn.inf = warn.inf),
    negbilog = fbvpnegbilog(x = x, u = u, start = start, ..., cshape =
      cshape, cscale = cscale, std.err = std.err, dsm = dsm,
      corr = corr, method = method, warn.inf = warn.inf),
    ct = fbvpct(x = x, u = u, start = start, ..., sym = sym, cshape =
      cshape, cscale = cscale, std.err = std.err, dsm = dsm,
      corr = corr, method = method, warn.inf = warn.inf))
}

################## censored likelihood fitting routines #################

fbvclog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvclog <- function(scale1, shape1, scale2, shape2, dep) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvclog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi,
      spx$lambda, dep, scale1, shape1, scale2, shape2, dns = double(1),
      PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "dep")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "log", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u)  
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE)
  f <- formals(nllbvclog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments")     
  formals(nllbvclog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvclog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvclog(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "log")
}

fbvcbilog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvcbilog <- function(scale1, shape1, scale2, shape2, alpha, beta) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvcbilog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$lambda,
      alpha, beta, scale1, shape1, scale2, shape2, dns = double(1),
      PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "alpha", "beta")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "bilog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, TRUE)
  f <- formals(nllbvcbilog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments")   
  formals(nllbvcbilog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvcbilog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvcbilog(", paste("p[", 1:l,
      "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "bilog")
}

fbvcalog <- function(x, u, start, ..., sym = FALSE, cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {
  nllbvcalog <- function(scale1, shape1, scale2, shape2, asy1, asy2, dep) {
    if(sym) asy2 <- asy1
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvcalog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$lambda,
       dep, asy1, asy2, scale1, shape1, scale2, shape2, dns = double(1),
       PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  if(!sym) param <- c(param, "asy1", "asy2", "dep")
  else param <- c(param, "asy1", "dep")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "alog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u)
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, !sym, TRUE)
  f <- formals(nllbvcalog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvcalog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvcalog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvcalog(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr,
    spx$nat, sym = sym, cmar = c(cscale, cshape), model = "alog")
}

fbvcneglog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvcneglog <- function(scale1, shape1, scale2, shape2, dep) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvcneglog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$lambda,
      dep, scale1, shape1, scale2, shape2, dns = double(1),
      PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "dep")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "neglog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE)
  f <- formals(nllbvcneglog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvcneglog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvcneglog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvcneglog(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "neglog")
}

fbvcnegbilog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvcnegbilog <- function(scale1, shape1, scale2, shape2, alpha, beta) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvcnegbilog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$lambda,
       alpha, beta, scale1, shape1, scale2, shape2, dns = double(1),
       PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "alpha", "beta")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "negbilog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, TRUE)
  f <- formals(nllbvcnegbilog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvcnegbilog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvcnegbilog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvcnegbilog(", paste("p[", 1:l,
      "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "negbilog")
}

fbvcaneglog <- function(x, u, start, ..., sym = FALSE, cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {
  
  nllbvcaneglog <- function(scale1, shape1, scale2, shape2, asy1, asy2, dep) {
    if(sym) asy2 <- asy1
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvcaneglog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$lambda,
       dep, asy1, asy2, scale1, shape1, scale2, shape2, dns = double(1),
       PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  if(!sym) param <- c(param, "asy1", "asy2", "dep")
  else param <- c(param, "asy1", "dep")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "aneglog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, !sym, TRUE)
  f <- formals(nllbvcaneglog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvcaneglog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvcaneglog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvcaneglog(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = sym, cmar = c(cscale, cshape), model = "aneglog")
}

fbvcct <- function(x, u, start, ..., sym = FALSE, cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvcct <- function(scale1, shape1, scale2, shape2, alpha, beta) {
    if(sym) beta <- alpha
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvcct", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$lambda,
      alpha, beta, scale1, shape1, scale2, shape2, dns = double(1),
      PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  if(!sym) param <- c(param, "alpha", "beta")
  else param <- c(param, "alpha")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "ct", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, !sym)
  f <- formals(nllbvcct)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvcct) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvcct(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvcct(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = sym, cmar = c(cscale, cshape), model = "ct")
}

fbvchr <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvchr <- function(scale1, shape1, scale2, shape2, dep) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvchr", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi,
      spx$lambda, dep, scale1, shape1, scale2, shape2, dns = double(1),
      PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "dep")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "hr", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u)  
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE)
  f <- formals(nllbvchr)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments")     
  formals(nllbvchr) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvchr(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvchr(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "hr")
}

################## Poisson likelihood fitting routines ##################

fbvplog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvplog <- function(scale1, shape1, scale2, shape2, dep) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvplog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$r1, spx$r2,
      spx$lambda, dep, scale1, shape1, scale2, shape2, dns = double(1),
      PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "dep")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "log", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u, censored = FALSE) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE)
  f <- formals(nllbvplog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments")   
  formals(nllbvplog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvplog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvplog(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr,
    spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "log")
}

fbvpneglog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvpneglog <- function(scale1, shape1, scale2, shape2, dep) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvpneglog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$r1,
      spx$r2, spx$lambda, dep, scale1, shape1, scale2, shape2,
      dns = double(1), PACKAGE = "evd")$dns    
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "dep")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "neglog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u, censored = FALSE)
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE)
  f <- formals(nllbvpneglog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvpneglog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvpneglog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvpneglog(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "neglog")
}

fbvpct <- function(x, u, start, ..., sym = FALSE, cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvpct <- function(scale1, shape1, scale2, shape2, alpha, beta) {
    if(sym) beta <- alpha
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvpct", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$r1, spx$r2,
      spx$lambda, alpha, beta, scale1, shape1, scale2, shape2,
      dns = double(1), PACKAGE = "evd")$dns
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  if(!sym) param <- c(param, "alpha", "beta")
  else param <- c(param, "alpha")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "ct", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u, censored = FALSE)
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, !sym)
  f <- formals(nllbvpct)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvpct) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvpct(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvpct(", paste("p[", 1:l, "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = sym, cmar = c(cscale, cshape), model = "ct")
}

fbvpbilog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvpbilog <- function(scale1, shape1, scale2, shape2, alpha, beta) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvpbilog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$r1,
      spx$r2, spx$lambda, alpha, beta, scale1, shape1, scale2, shape2,
      dns = double(1), PACKAGE = "evd")$dns    
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "alpha", "beta")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "bilog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u, censored = FALSE) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, TRUE)
  f <- formals(nllbvpbilog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvpbilog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvpbilog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvpbilog(", paste("p[", 1:l,
      "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "bilog")
}

fbvpnegbilog <- function(x, u, start, ..., cshape = cscale, cscale = FALSE, std.err = TRUE, dsm = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE) {

  nllbvpnegbilog <- function(scale1, shape1, scale2, shape2, alpha, beta) {
    if(cshape) shape2 <- shape1
    if(cscale) scale2 <- scale1
    .C("nllbvpnegbilog", spx$x1, spx$x2, spx$nn, spx$n, spx$thdi, spx$r1,
      spx$r2, spx$lambda, alpha, beta, scale1, shape1, scale2, shape2,
      dns = double(1), PACKAGE = "evd")$dns 
  }
  param <- c("scale1", "shape1")
  if(!cscale) param <- c(param, "scale2")
  if(!cshape) param <- c(param, "shape2")
  param <- c(param, "alpha", "beta")
  nmdots <- names(list(...))
  start <- bvstart.vals(x, start, NULL, NULL, nmdots, param, NULL,
    NULL, model = "negbilog", obj = "bvpot", u = u)
  spx <- sep.bvdata(x, obj = "bvpot", u = u, censored = FALSE) 
  nm <- names(start)
  l <- length(nm)
  fixed.param <- list(...)[nmdots %in% param]
  if(any(!(param %in% c(nm,names(fixed.param)))))
    stop("unspecified parameters")
  prind <- c(TRUE, TRUE, !cscale, !cshape, TRUE, TRUE)
  f <- formals(nllbvpnegbilog)[prind]
  names(f) <- param
  m <- match(nm, param)
  if(any(is.na(m))) 
    stop("`start' specifies unknown arguments") 
  formals(nllbvpnegbilog) <- c(f[m], f[-m])
  nll <- function(p, ...) nllbvpnegbilog(p, ...)
  if(l > 1) {
    body(nll) <- parse(text = paste("nllbvpnegbilog(", paste("p[", 1:l,
      "]", collapse=", "), ", ...)"))
  }
  start.arg <- c(list(p = unlist(start)), fixed.param)
  if(warn.inf && do.call("nll", start.arg) == 1e+06)
    warning("negative log-likelihood is infinite at starting values")
  opt <- optim(start, nll, hessian = std.err, ..., method = method)
  bvtpost.optim(x, u, opt, nm, fixed.param, std.err, dsm, corr, spx$nat, sym = FALSE, cmar = c(cscale, cshape), model = "negbilog")
}


###################### post-optimisation processing #####################

bvtpost.optim <- function(x, u, opt, nm, fixed.param, std.err, dsm, corr, nat, sym, cmar, model) {
  if(opt$convergence != 0) {
    warning(paste("optimization for", model, "may not have succeeded"), call. = FALSE)
      if(opt$convergence == 1) 
        opt$convergence <- "iteration limit reached"
  }
  else opt$convergence <- "successful"
  if(std.err) {
    tol <- .Machine$double.eps^0.5
    var.cov <- qr(opt$hessian, tol = tol)
    if(var.cov$rank != ncol(var.cov$qr)) 
      stop(paste("observed information matrix for", model, "is singular; use std.err = FALSE"))
    var.cov <- solve(var.cov, tol = tol)
    std.err <- diag(var.cov)
    if(any(std.err <= 0)) 
      stop(paste("observed information matrix for", model, "is singular; use std.err = FALSE"))
    std.err <- sqrt(std.err)
    names(std.err) <- nm
    if(corr) {
      .mat <- diag(1/std.err, nrow = length(std.err))
      corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm, nm))
      diag(corr) <- rep(1, length(std.err))
    }
    else corr <- NULL
  }
  else std.err <- corr <- NULL
  fixed <- unlist(fixed.param)
  param <- c(opt$par, fixed)
  fixed2 <- NULL
  if(cmar[1]) fixed2 <- c(fixed2, param["scale1"])
  if(cmar[2]) fixed2 <- c(fixed2, param["shape1"])
  if(sym) {
    if(model %in% c("alog","aneglog")) fixed2 <- c(fixed2, param["asy1"])
    if(model == "ct") fixed2 <- c(fixed2, param["alpha"])
  }
  if(!is.null(fixed2)) {
    names(fixed2) <- sub("1", "2", names(fixed2))
    names(fixed2) <- sub("alpha", "beta", names(fixed2))
  }
  param <- c(param, fixed2)
  if(dsm) {
    dep.sum <- numeric(3)
    if(model %in% c("log", "hr", "neglog")) {
      dep <- param["dep"]
      dep.sum[1] <- 2 * (1 - abvpar(dep = dep, model = model))
      dep.sum[2] <- 4 * integrate(function(x) 1 - abvpar(x, dep = dep, model = model), 0, 1)$value
    }
    if(model %in% c("alog", "aneglog")) {
      dep <- param["dep"]
      asy <- param[c("asy1", "asy2")]
      dep.sum[1] <- 2 * (1 - abvpar(dep = dep, asy = asy, model = model))
      dep.sum[2] <- 4 * integrate(function(x) 1 - abvpar(x, dep = dep, asy = asy, model = model), 0, 1)$value
      dffn <- function(x) abvpar(x, dep = dep, asy = asy, model = model) - abvpar(x, dep = dep, asy = rev(asy), model = model)
      dep.sum[3] <- 4 * integrate(dffn, 0, 0.5)$value/(3 - 2 * sqrt(2))
    }
    if(model %in% c("bilog", "negbilog", "ct")) {
      alpha <- param["alpha"]
      beta <- param["beta"]
      dep.sum[1] <- 2 * (1 - abvpar(alpha = alpha, beta = beta, model = model))
      dep.sum[2] <- 4 * integrate(function(x) 1 - abvpar(x, alpha = alpha, beta = beta, model = model), 0, 1)$value
      dffn <- function(x) abvpar(x, alpha = alpha, beta = beta, model = model) - abvpar(x, alpha = beta, beta = alpha, model = model)
      dep.sum[3] <- 4 * integrate(dffn, 0, 0.5)$value/(3 - 2 * sqrt(2))
    }
  }
  else dep.sum <- NULL
  list(estimate = opt$par, std.err = std.err, fixed = fixed, fixed2 = fixed2, param = param, deviance = 2 * opt$value, dep.summary = dep.sum, corr = corr, convergence = opt$convergence, counts = opt$counts, message = opt$message, data = x, threshold = u, n = nrow(x), nat = nat, sym = sym, cmar = cmar, model = model)
}


########################## method functions #########################


"print.bvpot" <-  function(x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:", deparse(x$call), "\n")
    cat("Deviance:", deviance(x), "\n")
    cat("AIC:", AIC(x), "\n")

    cat("\nThreshold:", round(x$threshold, digits), "\n")
    cat("Marginal Number Above:", x$nat[1:2], "\n")
    cat("Marginal Proportion Above:", round(x$nat[1:2]/x$n, digits), "\n")
    cat("Number Above:", x$nat[3], "\n")
    cat("Proportion Above:", round(x$nat[3]/x$n, digits), "\n")
    
    cat("\nEstimates\n")
    print.default(format(fitted(x), digits = digits), print.gap = 2, 
        quote = FALSE)
    if(!is.null(std.errors(x))) {
      cat("\nStandard Errors\n")
      print.default(format(std.errors(x), digits = digits),
          print.gap = 2, quote = FALSE)
    }
    if(!is.null(x$corr)) {
      cat("\nCorrelations\n")
      print.default(format(x$corr, digits = digits), print.gap = 2, 
          quote = FALSE)
    }
    if(!is.null(x$dep.summary)) {
      cat("\nDependence Structure\n")
      cat("  Dependence One:", x$dep.summary[1], "\n")
      cat("  Dependence Two:", x$dep.summary[2], "\n")
      cat("  Asymmetry:", x$dep.summary[3], "\n")
    }
    cat("\nOptimization Information\n")
    cat("  Convergence:", x$convergence, "\n")
    cat("  Function Evaluations:", x$counts["function"], "\n")
    if(!is.na(x$counts["gradient"]))
        cat("  Gradient Evaluations:", x$counts["gradient"], "\n")
    if(!is.null(x$message)) cat("  Message:", x$message, "\n")
    cat("\n")
    invisible(x)
}

plot.bvpot <- function(x, ...) {
  stop("no plot method currently implemented for bivariate threshold models")
}

chiplot <- function(data, nq = 100, qlim = NULL, which = 1:2, conf = 0.95, lty = 1, cilty = 2, col = 1, cicol = 1, xlim = c(0,1), ylim1 = NULL, ylim2 = c(-1,1), main1 = "Chi Plot", main2 = "Chi Bar Plot", xlab = "Quantile", ylab1 = "Chi", ylab2 = "Chi Bar", ask = nb.fig < length(which) && dev.interactive(), ...)
{
    data <- na.omit(data)
    n <- nrow(data)
    data <- cbind(rank(data[, 1])/(n + 1), rank(data[, 2])/(n + 1))
    rowmax <- apply(data, 1, max)
    rowmin <- apply(data, 1, min)
    eps <- .Machine$double.eps^0.5
    qlim2 <- c(min(rowmax) + eps, max(rowmin) - eps)
    if(!is.null(qlim)) {
      if(qlim[1] < qlim2[1]) stop("lower quantile limit is too low")
      if(qlim[2] > qlim2[2]) stop("upper quantile limit is too high")
      if(qlim[1] > qlim[2]) stop("lower quantile limit is less than upper quantile limit")
    } else qlim <- qlim2
    u <- seq(qlim[1], qlim[2], length = nq)

    cu <- cbaru <- numeric(nq)
    for(i in 1:nq) cu[i] <- mean(rowmax < u[i])
    for(i in 1:nq) cbaru[i] <- mean(rowmin > u[i])
    chiu <- 2 - log(cu)/log(u)
    chibaru <- (2 * log(1 - u))/log(cbaru) - 1
    cnst <- qnorm((1 + conf)/2)
    varchi <- ((1/log(u)^2 * 1)/cu^2 * cu * (1 - cu))/n
    varchi <- cnst * sqrt(varchi)
    varchibar <- (((4 * log(1 - u)^2)/(log(cbaru)^4 * cbaru^2)) * cbaru * (
		1 - cbaru))/n
    varchibar <- cnst * sqrt(varchibar)

    chiu <- cbind(chilow = chiu-varchi, chi = chiu, chiupp = chiu+varchi) 
    chibaru <- cbind(chiblow = chibaru-varchibar, chib = chibaru, chibupp =
      chibaru+varchibar)

    show <- logical(2)
    show[which] <- TRUE
    lty <- c(cilty, lty, cilty)
    col <- c(cicol, col, cicol)
    nb.fig <- prod(par("mfcol"))
    if (ask) {
      op <- par(ask = TRUE)
      on.exit(par(op))
    }
    tmp <- rep(-Inf, nq)
    tmp[u > 0.5] <- 2 - log(2*u[u > 0.5] - 1)/log(u[u > 0.5])
    chiu <- pmin(pmax(chiu, tmp), 1)
    chibaru <- pmin(pmax(chibaru, -1), 1)
    if(is.null(ylim1)) ylim1 <- c(min(c(chiu, 0)), 1)
    if(show[1]) {
      matplot(u, chiu, type = "l", lty = lty, col = col, xlim = xlim, ylim = ylim1,
              main = main1, xlab = xlab, ylab = ylab1, ...)
    }

    if(show[2]) {
      matplot(u, chibaru, type = "l", lty = lty, col = col, xlim = xlim, ylim = ylim2,
              main = main2, xlab = xlab, ylab = ylab2, ...)
    }

    plvals <- list(quantile = u, chi = chiu, chibar = chibaru)
    if(!show[1]) plvals$chi <- NULL
    if(!show[2]) plvals$chib <- NULL
    invisible(plvals)    
}


"rmvlog"<-
# Uses Algorithm 2.1 in Stephenson(2003)
function(n, dep, d = 2, mar = c(0,1,0))
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
       dep > 1) stop("invalid argument for `dep'")
    sim <- .C("rmvlog_tawn",
              as.integer(n), as.integer(d), as.double(dep),
              sim = double(d*n), PACKAGE = "evd")$sim
    mtransform(matrix(1/sim, ncol=d, byrow=TRUE), mar, inv = TRUE, drp = TRUE)
}

"rmvalog"<-
# Uses Algorithm 2.2 in Stephenson(2003)
function(n, dep, asy, d = 2, mar = c(0,1,0))
{
    nb <- 2^d-1
    dep <- rep(dep, length.out = nb-d)
    asy <- mvalog.check(asy, dep, d = d)
    dep <- c(rep(1,d), dep)
    sim <- .C("rmvalog_tawn",
              as.integer(n), as.integer(d), as.integer(nb), as.double(dep),
              as.double(t(asy)), sim = double(n*d), PACKAGE = "evd")$sim
    mtransform(matrix(1/sim, ncol=d, byrow=TRUE), mar, inv = TRUE, drp = TRUE)
}

"rmvevd" <-
function(n, dep, asy, model = c("log", "alog"), d = 2, mar = c(0,1,0))
{
  model <- match.arg(model)
  if(model == "log" && !missing(asy))
    warning("ignoring `asy' argument")
    
  switch(model,
    log = rmvlog(n = n, dep = dep, d = d, mar = mar),
    alog = rmvalog(n = n, dep = dep, asy = asy, d = d, mar = mar)) 
}

"pmvlog"<- 
function(q, dep, d = 2, mar = c(0,1,0), lower.tail = TRUE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(is.null(dim(q))) dim(q) <- c(1,d)
    if(ncol(q) != d) stop("`q' and `d' are not compatible")
    q <- mtransform(q, mar)
    pp <- exp(-apply(q^(1/dep),1,sum)^dep)
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pmvalog"<-
function(q, dep, asy, d = 2, mar = c(0,1,0), lower.tail = TRUE)
{
    nb <- 2^d-1
    dep <- rep(dep, length.out = nb-d)
    asy <- mvalog.check(asy, dep, d = d)
    dep <- c(rep(1,d), dep)
    if(is.null(dim(q))) dim(q) <- c(1,d)
    if(ncol(q) != d) stop("`q' and `d' are not compatible")
    q <- mtransform(q, mar)
    inner <- function(par)
        apply((rep(par[1:d], rep(nrow(q),d))*q)^(1/par[d+1]), 1, sum)^par[d+1]
    comps <- apply(cbind(asy,dep),1,inner)
    if(is.null(dim(comps))) dim(comps) <- c(1,nb)
    pp <- exp(-apply(comps,1,sum))
    if(!lower.tail) pp <- 1 - pp
    pp
}

"pmvevd" <-
function(q, dep, asy, model = c("log", "alog"), d = 2,
         mar = c(0,1,0), lower.tail = TRUE)
{
  model <- match.arg(model)
  if(model == "log" && !missing(asy))
    warning("ignoring `asy' argument")
    
  switch(model,
    log = pmvlog(q = q, dep = dep, d = d, mar = mar,
      lower.tail = lower.tail),
    alog = pmvalog(q = q, dep = dep, asy = asy, d = d, mar = mar,
      lower.tail = lower.tail)) 
}

"dmvlog"<- 
function(x, dep, d = 2, mar = c(0,1,0), log = FALSE)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
        dep > 1) stop("invalid argument for `dep'")
    if(is.null(dim(x))) dim(x) <- c(1,d)
    if(ncol(x) != d) stop("`x' and `d' are not compatible")
    if(is.list(mar)) {
      if(length(mar) != d) stop("`mar' and `d' are not compatible")
      for(i in 1:d) mar[[i]] <- matrix(t(mar[[i]]), nrow = nrow(x),
        ncol = 3, byrow = TRUE)
    }
    else mar <- matrix(t(mar), nrow = nrow(x), ncol = 3, byrow = TRUE)
    dns <- numeric(nrow(x))
    x <- mtransform(x, mar)
    ext <- apply(x, 1, function(z) any(z %in% c(0,Inf)))
    dns[ext] <- -Inf
    idep <- 1/dep
    cf <- matrix(0, nrow = d, ncol = d)
    diag(cf) <- dep^(1:d - 1)
    cf[,1] <- exp(lgamma(1:d - dep) - lgamma(1:d) - lgamma(1 - dep))
    if(d >= 3) {
      for(i in 3:d) {
        for(j in 2:(d-1))
          cf[i,j] <- ((i - 1 - j*dep) * cf[i-1,j] + dep*(j-1)*cf[i-1,j-1])/
            (i - 1)
      }
    }
    cf <- log(cf[d,]) - lgamma(1:d)
    if(any(!ext)) {
      x <- x[!ext, ,drop=FALSE]
      if(is.list(mar)) {
        marscl <- marshp <- matrix(NA, nrow = nrow(x), ncol = d)
        for(i in 1:d) {
          mar[[i]] <- mar[[i]][!ext, ,drop=FALSE]
          marscl[,i] <- mar[[i]][,2]
          marshp[,i] <- mar[[i]][,3]
        }
      }  
      else {
        mar <- mar[!ext, ,drop=FALSE]
        marscl <- mar[,2]
        marshp <- mar[,3]
      }
      z <- rowSums(x^(idep))^dep
      lx <- log(x)
      .expr1 <- rowSums(lx * (idep + marshp) - log(marscl))
      dns[!ext] <- .expr1 + (1 - d*idep) * log(z) - z
      lz <- matrix(log(z), nrow = d, ncol = nrow(x), byrow = TRUE)
      lz <- (0:(d-1)) * lz + cf
      dns[!ext] <- dns[!ext] + log(colSums(exp(lz))) +
        lgamma(d) - (d-1)*log(dep)
    }
    if(!log) dns <- exp(dns)
    dns
}

"dmvalog"<- 
function(x,  dep, asy, d = 2, mar = c(0,1,0), log = FALSE)
{
    nb <- 2^d-1
    dep <- rep(dep, length.out = nb-d)
    ss <- mvalog.check(asy, dep, d = d, ss = TRUE)
    asy <- ss$asy ; ss <- ss$ss
    dep <- c(rep(1,d), dep)
    if(is.null(dim(x))) dim(x) <- c(1,d)
    if(ncol(x) != d) stop("`x' and `d' are not compatible")
    nn <- nrow(x)
    if(is.list(mar)) {
      if(length(mar) != d) stop("`mar' and `d' are not compatible")
      for(i in 1:d) mar[[i]] <- matrix(t(mar[[i]]), nrow = nn,
        ncol = 3, byrow = TRUE)
    }
    else mar <- matrix(t(mar), nrow = nn, ncol = 3, byrow = TRUE)
    x<- mtransform(x, mar)
    ext <- apply(x, 1, function(z) any(z %in% c(0,Inf)))
    dns <- numeric(nn)
    dns[ext] <- -Inf

    if(any(!ext)) {
      x <- x[!ext, ,drop=FALSE]
      if(is.list(mar)) {
        marscl <- marshp <- matrix(NA, nrow = nn, ncol = d)
        for(i in 1:d) {
          mar[[i]] <- mar[[i]][!ext, ,drop=FALSE]
          marscl[,i] <- mar[[i]][,2]
          marshp[,i] <- mar[[i]][,3]
        }
      }  
      else {
        mar <- mar[!ext, ,drop=FALSE]
        marscl <- mar[,2]
        marshp <- mar[,3]
      }
      cfinit <- function(dep) {
        cf <- matrix(0, nrow = d, ncol = d)
        diag(cf) <- dep^(1:d - 1)
        cf[,1] <- exp(lgamma(1:d - dep) - lgamma(1:d) - lgamma(1 - dep))
        if(d >= 3) {
          for(i in 3:d) {
            for(j in 2:(d-1))
              cf[i,j] <- ((i - 1 - j*dep) * cf[i-1,j] + dep * (j-1) *
                cf[i-1,j-1])/(i - 1)
          }
        }
        cf
      }
      cfs <- paste("cf", 1:nb, sep = "")
      for(i in 1:nb) assign(cfs[i], cfinit(dep[i]))
      qfn <- function(lz, dep, p, cf) {
        if(p == 1) return(rep(0, nn))
        cf <- log(cf[p,1:p]) - lgamma(1:p)
        lz <- matrix(lz, nrow = p, ncol = nn, byrow = TRUE)
        lz <- ((1-p):0) * lz + cf
        log(colSums(exp(lz))) + lgamma(p) - (p-1)*log(dep) 
      }
      indm <- matrix(NA, nrow = 2^(d-1), ncol = d)
      for(i in 1:d) indm[,i] <- which(sapply(ss, function(x) i %in% x))
      indm <- as.matrix(do.call("expand.grid", as.data.frame(indm)))
      inner <- function(par) {
        int <- (rep(par[1:d], each = nn) * x)^(1/par[d+1])
        rowSums(int)^par[d+1]
      }
      zm <- log(apply(cbind(asy,dep), 1, inner))
      if(is.null(dim(zm))) dim(zm) <- c(1,nb)
      vv <- rowSums(exp(zm))
      lx <- log(x)
      mexpr <- rowSums(lx * marshp - log(marscl))
      
      tot1 <- matrix(0, nrow = nn, ncol = 2^(d*(d-1)))
      tot2 <- matrix(0, nrow = nn, ncol = d)
      for(i in 1:(2^(d*(d-1)))) {
        indmi <- indm[i,]
        pp <- tabulate(indmi, 2^d-1)[indmi]
        if(all(asy[indmi + (2^d-1)*(0:(d-1))])) {
          for(j in 1:d) 
            tot2[,j] <- 1/dep[indmi[j]] * (log(asy[indmi[j],j]) + lx[,j]) +
              (1 - 1/dep[indmi[j]]) * zm[,indmi[j]] + qfn(zm[,indmi[j]],
              dep[indmi[j]], pp[j], get(cfs[indmi[j]])) / pp[j]
          tot1[,i] <- rowSums(tot2)
        }
        else tot1[,i] <- -Inf
      }
      dns[!ext] <- log(rowSums(exp(tot1))) - vv + mexpr
    }
    if(!log) dns <- exp(dns)
    dns
}

"dmvevd" <-
function(x, dep, asy, model = c("log", "alog"), d = 2,
         mar = c(0,1,0), log = FALSE)
{
  model <- match.arg(model)
  if(model == "log" && !missing(asy))
    warning("ignoring `asy' argument")

  switch(model,
    log = dmvlog(x = x, dep = dep, d = d, mar = mar, log = log),
    alog = dmvalog(x = x, dep = dep, asy = asy, d = d, mar = mar, log = log))
}   

"atvlog"<- 
function(x, dep, plot = FALSE, col = heat.colors(12), blty = 0,
    grid = if(blty) 150 else 50, lower = 1/3, ord = 1:3, lab =
    as.character(1:3), lcex = 1)
{
    if(length(dep) != 1 || mode(dep) != "numeric" || dep <= 0 ||
      dep > 1) stop("invalid argument for `dep'")
    depfn <- function(x, dep) rowSums(x^(1/dep))^dep
    if(plot) {
      mz <- tvdepfn(depfn = depfn, col = col, blty = blty, grid = grid,
        lower = lower, ord = ord, lab = lab, lcex = lcex, dep = dep)
      return(invisible(mz))
    }
    depfn(x = x, dep = dep)   
}

"atvalog"<- 
function(x, dep, asy, plot = FALSE, col = heat.colors(12), blty = 0,
    grid = if(blty) 150 else 50, lower = 1/3, ord = 1:3, lab =
    as.character(1:3), lcex = 1)
{
    dep <- c(rep(dep, length.out = 4))
    asy <- mvalog.check(asy, dep, d = 3)
    depfn <- function(x, dep, asy) {
      dep <- c(rep(1,3), dep)
      tot <- matrix(0, nrow = nrow(x), ncol = 7)
      idep <- 1/dep
      x <- t(x)
      for(k in 1:7)
        tot[,k] <- colSums((asy[k,] * x)^idep[k])^dep[k]
      rowSums(tot)
    }
    if(plot) {
      mz <- tvdepfn(depfn = depfn, col = col, blty = blty, grid = grid,
        lower = lower, ord = ord, lab = lab, lcex = lcex, dep = dep,
        asy = asy)
      return(invisible(mz))
    }
    depfn(x = x, dep = dep, asy = asy)   
}

"tvdepfn" <- 
function(depfn, col = heat.colors(12), blty = 0, grid =
    if(blty) 150 else 50, lower = 1/3, ord = 1:3, lab = as.character(1:3),
    lcex = 1, ...)
{
    oldpar <- par(pty="s")
    on.exit(par(oldpar))

    s3 <- sqrt(1/3)
    x <- seq(-s3, s3, len = 2*grid)
    y <- seq(0, 1, len = 2*grid)
    a <- function(x,y) {
        w1 <- y
        w2 <- (x/s3 + 1 - y)/2
        vals <- numeric(length(w1))
        tpts <- cbind(w1,w2,w3=1-w1-w2)[, ord]
        nv <- apply(tpts, 1, function(b) any(b < 0))
        is.na(vals) <- nv
        vals[!nv] <- depfn(tpts[!nv,], ...)
        vals
    }
    z <- outer(x,y,a)
    mz <- min(z, na.rm = TRUE)
    mxz <- max(z, na.rm = TRUE)
    if(mz < 1/3 || mxz > 1 || any(is.nan(z)))
      warning("parameters may be too near edge of parameter space")
    else if(mz < lower)
      warning("`lower' is greater than calculated values")
    plot(c(-s3, s3), c(0.5-s3, 0.5+s3), type="n", axes=FALSE, xlab="", ylab="")
    if(!is.null(lab)) {
      lab <- lab[ord]
      eps <- 0.05 * lcex
      text(0, 1+eps, lab[1], adj = c(0.5, 0.5), cex = lcex)
      text(s3+0.05*0.75, -0.75*eps, lab[2], adj = c(1, 1), cex = lcex)
      text(-s3-0.05*0.75, -0.75*eps, lab[3], adj = c(0, 1), cex = lcex)
    }
    image(x, y, z, zlim = c(lower,1), xlim = c(-s3,s3), ylim =
          c(0.5-s3, 0.5+s3), col = col, add = TRUE)
    polygon(c(-s3, s3, 0), c(0, 0, 1), lty = blty)
    invisible(mz)
}

"atvpar" <-
function(x = rep(1/3,3), dep, asy, model = c("log", "alog"), plot =
    FALSE, col = heat.colors(12), blty = 0, grid = if(blty) 150 else 50,
    lower = 1/3, ord = 1:3, lab = as.character(1:3), lcex = 1)
{
  model <- match.arg(model)
  if(model == "log" && !missing(asy))
    warning("ignoring `asy' argument") 

  if(!plot) {
    if(is.vector(x)) x <- as.matrix(t(x))
    if(!is.matrix(x) || ncol(x) != 3)
      stop("`x' must be a vector/matrix with three elements/columns")
    if(any(x < 0, na.rm = TRUE))
      stop("`x' must be non-negative")
    rs <- rowSums(x)
    if(any(rs <= 0, na.rm = TRUE))
      stop("row(s) of `x' must have a positive sum")
    if(max(abs(rs[!is.na(rs)] - 1)) > 1e-6)
      warning("row(s) of `x' will be rescaled")
    x <- x/rs
  }
     
  switch(model,
    log = atvlog(x = x, dep = dep, plot = plot, col = col, blty = blty,
      grid = grid, lower = lower, ord = ord, lab = lab, lcex = lcex),
    alog = atvalog(x = x, dep = dep, asy = asy, plot = plot, col = col, blty =
      blty, grid = grid, lower = lower, ord = ord, lab = lab, lcex = lcex))
}
 
"atvnonpar"<- 
function(x = rep(1/3,3), data, nsloc1 = NULL, nsloc2 = NULL, nsloc3 = NULL,
    method = c("pickands","deheuvels","hall"), kmar = NULL,
    plot = FALSE, col = heat.colors(12), blty = 0, grid = if(blty) 150 else 50,
    lower = 1/3, ord = 1:3, lab = as.character(1:3), lcex = 1)
{
    if(!plot) {
      if(is.vector(x)) x <- as.matrix(t(x))
      if(!is.matrix(x) || ncol(x) != 3)
        stop("`x' must be a vector/matrix with three elements/columns")
      if(any(x < 0, na.rm = TRUE))
        stop("`x' must be non-negative")
      rs <- rowSums(x)
      if(any(rs <= 0, na.rm = TRUE))
        stop("row(s) of `x' must have a positive sum")
      if(max(abs(rs[!is.na(rs)] - 1)) > 1e-6)
        warning("row(s) of `x' will be rescaled")
      x <- x/rs
    }
    if(is.null(kmar)) {
        if(!is.null(nsloc1)) {
            nsloc1 <- nsloc.transform(data, nsloc1)
            nslocmat1 <- cbind(1,as.matrix(nsloc1))
        }
        if(!is.null(nsloc2)) {
            nsloc2 <- nsloc.transform(data, nsloc2)
            nslocmat2 <- cbind(1,as.matrix(nsloc2))
        }
        if(!is.null(nsloc3)) {
            nsloc3 <- nsloc.transform(data, nsloc3)
            nslocmat3 <- cbind(1,as.matrix(nsloc3))
        }
        # Transform to exponential margins
        mle.m1 <- fgev(data[,1], nsloc = nsloc1, std.err = FALSE)$estimate
        loc.mle.m1 <- mle.m1[grep("^loc", names(mle.m1))]
        if(is.null(nsloc1)) loc.mle.m1 <- rep(loc.mle.m1, nrow(data))
        else loc.mle.m1 <- nslocmat1 %*% loc.mle.m1
        mle.m1 <- cbind(loc.mle.m1, mle.m1["scale"], mle.m1["shape"])
        
        mle.m2 <- fgev(data[,2], nsloc = nsloc2, std.err = FALSE)$estimate
        loc.mle.m2 <- mle.m2[grep("^loc", names(mle.m2))]
        if(is.null(nsloc2)) loc.mle.m2 <- rep(loc.mle.m2, nrow(data))
        else loc.mle.m2 <- nslocmat2 %*% loc.mle.m2
        mle.m2 <- cbind(loc.mle.m2, mle.m2["scale"], mle.m2["shape"])

        mle.m3 <- fgev(data[,3], nsloc = nsloc3, std.err = FALSE)$estimate
        loc.mle.m3 <- mle.m3[grep("^loc", names(mle.m3))]
        if(is.null(nsloc3)) loc.mle.m3 <- rep(loc.mle.m3, nrow(data))
        else loc.mle.m3 <- nslocmat3 %*% loc.mle.m3
        mle.m3 <- cbind(loc.mle.m3, mle.m3["scale"], mle.m3["shape"])

        data <- mtransform(data, list(mle.m1, mle.m2, mle.m3))
        # End transform
    }
    else {
        if(length(kmar) != 3 || mode(kmar) != "numeric")
            stop("`kmar' should be a numeric vector of length three")
        if(!is.null(nsloc1) || !is.null(nsloc2) || !is.null(nsloc3))
            warning("ignoring `nsloc1', `nsloc2' and `nsloc3' arguments")
        data <- mtransform(data, kmar)
    }
    
    data <- na.omit(data)
    method <- match.arg(method)
    mpmin <- function(a,b,c) {
      a[a > b] <- b[a > b]
      a[a > c] <- c[a > c]
      a
    }
    
    if(method == "pickands") {
      depfn <- function(x, data) {
        nn <- nrow(data)
        a <- numeric(nrow(x))
        for(i in 1:nrow(x))
          a[i] <- sum(mpmin(data[,1]/x[i,1], data[,2]/x[i,2], data[,3]/x[i,3]))
        a <- nn / a
        pmin(1, pmax(a, x[,1], x[,2], x[,3]))
      }
    }
    
    if(method == "deheuvels") {
      depfn <- function(x, data) {
        nn <- nrow(data)
        a <- numeric(nrow(x))
        for(i in 1:nrow(x))
          a[i] <- sum(mpmin(data[,1]/x[i,1], data[,2]/x[i,2], data[,3]/x[i,3]))
        a <- nn / (a - x[,1] * sum(data[,1]) - x[,2] * sum(data[,2]) -
          x[,3] * sum(data[,3]) + nn)
        pmin(1, pmax(a, x[,1], x[,2], x[,3]))
      }
    }

    if(method == "hall") {
      depfn <- function(x, data) {
        csum <- colSums(data)
        a <- numeric(nrow(x))
        for(i in 1:nrow(x))
          a[i] <- sum(mpmin(data[,1]/(csum[1] * x[i,1]),
            data[,2]/(csum[2] * x[i,2]), data[,3]/(csum[3] * x[i,3])))
        a <- 1 / a
        pmin(1, pmax(a, x[,1], x[,2], x[,3]))
      }
    }

    if(plot) {
      mz <- tvdepfn(depfn = depfn, col = col, blty = blty, grid = grid,
        lower = lower, ord = ord, lab = lab, lcex = lcex, data = data)
      return(invisible(mz))
    }
    depfn(x = x, data = data)
}

mvalog.check <- function(asy, dep, d, ss = FALSE)
{
    if(mode(dep) != "numeric" || any(dep <= 0) || any(dep > 1))
      stop("invalid argument for `dep'")
    nb <- 2^d-1
    if(mode(asy) != "list" || length(asy) != nb)
      stop(paste("`asy' should be a list of length", nb))

    subsets <- function(d) {
        x <- 1:d
        k <- NULL
        for(m in x) 
            k <- rbind(cbind(TRUE, k), cbind(FALSE, k))
        pset <- apply(k, 1, function(z) x[z])
        pset[sort.list(unlist(lapply(pset,length)))[-1]] 
    }
    tasy <- function(theta, b) {
        trans <- matrix(0, nrow=nb, ncol=d)
        for(i in 1:nb) trans[i,(1:d %in% b[[i]])] <- theta[[i]]
        trans
    }
    
    b <- subsets(d)
    if(any(sapply(asy, length) != sapply(b, length)))
      stop("`asy' is not of the correct form")
    asy <- tasy(asy, b)
    if(!is.matrix(asy) || mode(asy) != "numeric")
        stop("`asy' is not of the correct form")
    if(min(asy) < 0 || max(asy) > 1)
       stop("`asy' must contain parameters in [0,1]")
    if(any(apply(asy,2,sum) != 1) || any(asy[c(rep(FALSE,d),dep==1),] != 0) ||
       any(apply(asy[-(1:d),,drop=FALSE],1,function(x) sum(x!=0)) == 1))
       stop("`asy' does not satisfy the appropriate constraints")
    if(ss) return(list(asy = asy, ss = b))
    asy
}


  
"pgpd" <-
function(q, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
{
    if(min(scale) <= 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    q <- pmax(q - loc, 0)/scale
    if(shape == 0) p <- 1 - exp(-q)
    else {
        p <- pmax(1 + shape * q, 0)
        p <- 1 - p^(-1/shape)
    }
    if(!lower.tail) p <- 1 - p
    p
}

"dgpd"<-
function(x, loc = 0, scale = 1, shape = 0, log = FALSE)
{
    if(min(scale) <= 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    d <- (x - loc)/scale
    nn <- length(d)
    scale <- rep(scale, length.out = nn)
    index <- (d > 0 & ((1 + shape * d) > 0)) | is.na(d)
    if(shape == 0) {
      d[index] <- log(1/scale[index]) - d[index]
      d[!index] <- -Inf
    }
    else {
        d[index] <- log(1/scale[index]) - (1/shape + 1) *
          log(1 + shape * d[index])
        d[!index] <- -Inf
    }
    if(!log) d <- exp(d)
    d
}

"qgpd"<-
function(p, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
{
    if(min(p, na.rm = TRUE) <= 0 || max(p, na.rm = TRUE) >=1)
        stop("`p' must contain probabilities in (0,1)")
    if(min(scale) < 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    if(lower.tail) p <- 1 - p
    if(shape == 0) return(loc - scale*log(p))
    else return(loc + scale * (p^(-shape) - 1) / shape)
}

"rgpd"<-
function(n, loc = 0, scale = 1, shape = 0)
{
    if(min(scale) < 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    if(shape == 0) return(loc + scale*rexp(n))
    else return(loc + scale * (runif(n)^(-shape) - 1) / shape)
}

"mrlplot"<-
function(data, tlim, nt = max(100, length(data)), lty = c(2,1,2), col = 1,
    conf = 0.95, main = "Mean Residual Life Plot", xlab = "Threshold",
    ylab = "Mean Excess", ...)
{
    data <- sort(data[!is.na(data)])
    nn <- length(data)
    if(nn <= 5) stop("`data' has too few non-missing values")
    if(missing(tlim)) {
      tlim <- c(data[1], data[nn - 4])
      tlim <- tlim - .Machine$double.eps^0.5
    }
    if(all(data <= tlim[2]))
      stop("upper limit for threshold is too high") 
    u <- seq(tlim[1], tlim[2], length = nt)
    x <- matrix(NA, nrow = nt, ncol = 3, dimnames = list(NULL,
        c("lower", "mrl", "upper")))
    for(i in 1:nt) {
        data <- data[data > u[i]]
	x[i,2] <- mean(data - u[i])
	sdev <- sqrt(var(data))
        sdev <- (qnorm((1 + conf)/2) * sdev)/sqrt(length(data))
	x[i,1] <- x[i,2] - sdev
	x[i,3] <- x[i,2] + sdev
    }
    matplot(u, x, type = "l", lty = lty, col = col, main = main,
            xlab = xlab, ylab = ylab, ...)
    invisible(list(x = u, y = x))
}

"tcplot"<-
function(data, tlim, model = c("gpd", "pp"), cmax = FALSE, r = 1, ulow =
    -Inf, rlow = 1, nt = 25, which = 1:npar, conf = 0.95, lty = 1, lwd = 1,
    type = "b", cilty = 1, ask = nb.fig < length(which) &&
    dev.interactive(), ...)
{
    model <- match.arg(model)
    u <- seq(tlim[1], tlim[2], length = nt)   
    locs <- scls <- shps <- matrix(NA, nrow = nt, ncol = 3)
    dimnames(locs) <- list(round(u,2), c("lower", "loc", "upper"))
    dimnames(shps) <- list(round(u,2), c("lower", "shape", "upper"))
    if(model == "gpd") {
      pname <- "mscale"
      npar <- 2
    }
    if(model == "pp") {
      pname <- "scale"
      npar <- 3
    }
    dimnames(scls) <- list(round(u,2), c("lower", pname, "upper"))
    z <- fpot(data, u[1], model = model, cmax = cmax, r = r, ulow = ulow,
              rlow = rlow, corr = TRUE, ...)
    stvals <- as.list(round(fitted(z), 3))
    for(i in 1:nt) {
      z <- fpot(data, u[i], model = model, start = stvals, cmax = cmax,
                r = r, ulow = ulow, rlow = rlow, corr = TRUE, ...)
      stvals <- as.list(fitted(z))
      mles <- fitted(z)
      stderrs <- std.errors(z)
      cnst <- qnorm((1 + conf)/2)
      shp <- mles["shape"]
      scl <- mles["scale"]
      shpse <- stderrs["shape"]
      sclse <- stderrs["scale"]
      if(model == "pp") {
        loc <- mles["loc"]  
        locse <- stderrs["loc"]
        locs[i,] <- c(loc - cnst*locse, loc, loc + cnst*locse)
      } 
      if(model == "gpd") {
        scl <- scl - shp*u[i]
        covar <- z$corr[1,2] * prod(stderrs)
        sclse <- sqrt(sclse^2 - 2*u[i]*covar + (u[i]*shpse)^2)
      }
      scls[i,] <- c(scl - cnst*sclse, scl, scl + cnst*sclse)
      shps[i,] <- c(shp - cnst*shpse, shp, shp + cnst*shpse)      
   }
   show <- rep(FALSE, npar)
   show[which] <- TRUE
   nb.fig <- prod(par("mfcol"))
   if (ask) {
     op <- par(ask = TRUE)
     on.exit(par(op))
   }
   if(model == "pp") {
     if(show[1]) {
       matplot(u, locs, type = "n", xlab = "Threshold",
               ylab = "Location")
       lines(u, locs[,2], lty = lty, lwd = lwd, type = type)
       segments(u, locs[,1], u, locs[,3], lty = cilty)
     }
     if(show[2]) {
       matplot(u, scls, type = "n", xlab = "Threshold",
               ylab = "Scale")
       lines(u, scls[,2], lty = lty, lwd = lwd, type = type)
       segments(u, scls[,1], u, scls[,3], lty = cilty)
     }
     if(show[3]) {
     matplot(u, shps, type = "n", xlab = "Threshold",
             ylab = "Shape")
     lines(u, shps[,2], lty = lty, lwd = lwd, type = type)
     segments(u, shps[,1], u, shps[,3], lty = cilty)
     }
     rtlist <- list(locs = locs, scales = scls, shapes = shps) 
   }
   if(model == "gpd") {
     if(show[1]) {
       matplot(u, scls, type = "n", xlab = "Threshold",
               ylab = "Modified Scale")
     lines(u, scls[,2], lty = lty, lwd = lwd, type = type)
     segments(u, scls[,1], u, scls[,3], lty = cilty)
     }
     if(show[2]) {
       matplot(u, shps, type = "n", xlab = "Threshold",
               ylab = "Shape")
       lines(u, shps[,2], lty = lty, lwd = lwd, type = type)
       segments(u, shps[,1], u, shps[,3], lty = cilty)
     }
     rtlist <- list(scales = scls, shapes = shps) 
   } 
   invisible(rtlist)
}

"fpot.norm"<-
function(x, threshold, model, start, npp = length(x), cmax = FALSE, r = 1, ulow = -Inf, rlow = 1, ..., std.err = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    if(model == "gpd") {
      nlpot <- function(scale, shape) { 
        .C("nlgpd",
            exceed, nhigh, threshold, scale, shape, dns = double(1),
            PACKAGE = "evd")$dns
      }
    }
    if(model == "pp") {
      nlpot <- function(loc, scale, shape) {
        .C("nlpp",
            exceed, nhigh, loc, scale, shape, threshold, nop,
            dns = double(1), PACKAGE = "evd")$dns
      }
    }
    nn <- length(x)
    nop <- as.double(nn/npp)
    if(cmax) {
      exceed <- clusters(x, u = threshold, r = r, ulow = ulow, rlow = rlow,
        cmax = TRUE, keep.names = FALSE)
      extind <- attributes(exceed)$acs
      exceed <- as.double(exceed)
      nhigh <- length(exceed) ; nat <- as.integer(nhigh * extind)
      extind <- 1/extind
    }
    else {
      extind <- r <- NULL
      high <- (x > threshold) & !is.na(x)
      exceed <- as.double(x[high])
      nhigh <- nat <- length(exceed)
    }
    if(!nhigh) stop("no data above threshold")
    pat <- nat/nn
    param <- c("scale", "shape")
    if(model == "pp") param <- c("loc", param)
    if(missing(start)) {
        if(model == "gpd") {
          start <- list(scale = 0, shape = 0)
          start$scale <- mean(exceed) - threshold
        }
        if(model == "pp") {
          start <- list(loc = 0, scale = 0, shape = 0)
          start$scale <- sqrt(6 * var(x))/pi
          start$loc <- mean(x) + (log(nop) - 0.58) * start$scale
        }
        start <- start[!(param %in% names(list(...)))]
    }
    if(!is.list(start)) 
        stop("`start' must be a named list")
    if(!length(start))
        stop("there are no parameters left to maximize over")
    nm <- names(start)
    l <- length(nm)
    f <- formals(nlpot)
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlpot) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlpot(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlpot(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    fixed.param <- list(...)[names(list(...)) %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    if (opt$convergence != 0) {
        warning("optimization may not have succeeded")
        if(opt$convergence == 1) opt$convergence <- "iteration limit reached"
    }
    else opt$convergence <- "successful"
    if(std.err) {
        tol <- .Machine$double.eps^0.5
        var.cov <- qr(opt$hessian, tol = tol)
        if(var.cov$rank != ncol(var.cov$qr)) 
            stop("observed information matrix is singular; use std.err = FALSE")
        var.cov <- solve(var.cov, tol = tol)
        std.err <- diag(var.cov)
        if(any(std.err <= 0))
            stop("observed information matrix is singular; use std.err = FALSE")
        std.err <- sqrt(std.err)
        names(std.err) <- nm
        if(corr) {
            .mat <- diag(1/std.err, nrow = length(std.err))
            corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm,nm))
            diag(corr) <- rep(1, length(std.err))
        }
        else corr <- NULL
    }
    else std.err <- corr <- NULL
    param <- c(opt$par, unlist(fixed.param))
   if(model == "gpd") scale <- param["scale"]
   if(model == "pp") scale <- param["scale"] + param["shape"] * (threshold -
     param["loc"])
    
    list(estimate = opt$par, std.err = std.err, fixed = unlist(fixed.param),
        param = param, deviance = 2*opt$value, corr = corr, convergence =
        opt$convergence, counts = opt$counts, message = opt$message,
        threshold = threshold, r = r, ulow = ulow, rlow = rlow, npp = npp,
        nhigh = nhigh, nat = nat, pat = pat, extind = extind,
        data = x, exceedances = exceed, mper = NULL, scale = scale)
}

"fpot.quantile"<-
function(x, threshold, start, npp = length(x), cmax = FALSE, r = 1, ulow = -Inf, rlow = 1, mper, ..., std.err = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlpot <- function(rlevel, shape)
    {
        if(is.infinite(mper) && shape >= 0) return(1e6)
        rlevel <- rlevel - threshold
        if(shape == 0) scale <- rlevel / log(adjmper)
        else scale <- shape * rlevel / (adjmper^shape - 1)
        .C("nlgpd",
            exceed, nhigh, threshold, scale, shape, dns = double(1),
            PACKAGE = "evd")$dns
    }
    nn <- length(x)
    if(cmax) {
      exceed <- clusters(x, u = threshold, r = r, ulow = ulow, rlow = rlow,
        cmax = TRUE, keep.names = FALSE)
      extind <- attributes(exceed)$acs
      exceed <- as.double(exceed)
      nhigh <- length(exceed) ; nat <- as.integer(nhigh * extind)
      extind <- 1/extind
    }
    else {
      extind <- r <- NULL
      high <- (x > threshold) & !is.na(x)
      exceed <- as.double(x[high])
      nhigh <- nat <- length(exceed)
    }
    if(!nhigh) stop("no data above threshold")
    pat <- nat/nn
    adjmper <- mper * npp * nhigh/nn
    if(adjmper <= 1) stop("`mper' is too small")
    param <- c("rlevel", "shape")
    if(missing(start)) {
        start <- list(rlevel = 0, shape = 0)
        stscale <- mean(exceed) - threshold
        start$rlevel <- threshold + stscale*log(adjmper)
        if(is.infinite(mper)) {
          stmp <- 100/(npp * nhigh/nn)
          fpft <- fpot(x = x, threshold = threshold, npp = npp, cmax =
            cmax, r = r, ulow = ulow, rlow = rlow, mper = stmp, ...,
            std.err = std.err, corr = corr, method = method, warn.inf =
            warn.inf)
          start <- as.list(fitted(fpft))
        }
        start <- start[!(param %in% names(list(...)))]
    }
    if(!is.list(start)) 
        stop("`start' must be a named list")
    if(!length(start))
        stop("there are no parameters left to maximize over")
    nm <- names(start)
    l <- length(nm)
    f <- formals(nlpot)
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlpot) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlpot(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlpot(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    fixed.param <- list(...)[names(list(...)) %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    if (opt$convergence != 0) {
        warning("optimization may not have succeeded")
        if(opt$convergence == 1) opt$convergence <- "iteration limit reached"
    }
    else opt$convergence <- "successful"
    if(std.err) {
        tol <- .Machine$double.eps^0.5
        var.cov <- qr(opt$hessian, tol = tol)
        if(var.cov$rank != ncol(var.cov$qr)) 
            stop("observed information matrix is singular; use std.err = FALSE")
        var.cov <- solve(var.cov, tol = tol)
        std.err <- diag(var.cov)
        if(any(std.err <= 0))
            stop("observed information matrix is singular; use std.err = FALSE")
        std.err <- sqrt(std.err)
        names(std.err) <- nm
        if(corr) {
            .mat <- diag(1/std.err, nrow = length(std.err))
            corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm,nm))
            diag(corr) <- rep(1, length(std.err))
        }
        else corr <- NULL
    }
    else std.err <- corr <- NULL
    param <- c(opt$par, unlist(fixed.param))
    rlevel <- param["rlevel"] - threshold
    if(param["shape"] == 0) scale <- rlevel / log(adjmper)
    else scale <- param["shape"] * rlevel / (adjmper^param["shape"] - 1) 
    list(estimate = opt$par, std.err = std.err, fixed = unlist(fixed.param),
        param = param, deviance = 2*opt$value, corr = corr, convergence =
        opt$convergence, counts = opt$counts, message = opt$message,
        threshold = threshold, r = r, ulow = ulow, rlow = rlow, npp = npp,
        nhigh = nhigh, nat = nat, pat = pat, extind = extind,
        data = x, exceedances = exceed, mper = mper, scale = scale)
}

"fpot"<-
function(x, threshold, model = c("gpd", "pp"), start, npp = length(x), cmax = FALSE, r = 1, ulow = -Inf, rlow = 1, mper = NULL, ..., std.err = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
  call <- match.call()
  model <- match.arg(model)
  if(missing(x) || length(x) == 0 || mode(x) != "numeric") 
    stop("`x' must be a non-empty numeric vector")
  if(missing(threshold) || length(threshold) != 1 ||
     mode(threshold) != "numeric") 
    stop("`threshold' must be a numeric value")
  threshold <- as.double(threshold)
  if(is.null(mper)) {
    ft <- fpot.norm(x = x, threshold = threshold, model = model, start = start,
      npp = npp, cmax = cmax, r = r, ulow = ulow, rlow = rlow, ...,
      std.err = std.err, corr = corr, method = method, warn.inf = warn.inf)
  }
  else {
    if(model == "pp")
      stop("`mper' cannot be specified in point process models")
    ft <- fpot.quantile(x = x, threshold = threshold, start =
      start, npp = npp, cmax = cmax, r = r, ulow = ulow, rlow = rlow, ...,
      mper = mper, std.err = std.err, corr = corr, method = method,
      warn.inf = warn.inf)
  }
  structure(c(ft, call = call), class = c("pot", "uvevd", "evd"))
}

"print.pot" <-  function(x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:", deparse(x$call), "\n")
    cat("Deviance:", x$deviance, "\n")

    cat("\nThreshold:", round(x$threshold, digits), "\n")
    cat("Number Above:", x$nat, "\n")
    cat("Proportion Above:", round(x$pat, digits), "\n")
    if(!is.null(x$extind)) {
      cat("\nClustering Interval:", x$r, "\n")
      if(is.finite(x$ulow)) {
        cat("Lower Threshold:", round(x$ulow, digits), "\n")
        cat("Lower Clustering Interval:", x$rlow, "\n")
      }
      cat("Number of Clusters:", x$nhigh, "\n")
      cat("Extremal Index:", round(x$extind, digits), "\n")
    }
    
    cat("\nEstimates\n") 
    print.default(format(x$estimate, digits = digits), print.gap = 2, 
        quote = FALSE)
    if(!is.null(x$std.err)) {
    cat("\nStandard Errors\n")
    print.default(format(x$std.err, digits = digits), print.gap = 2, 
        quote = FALSE)
    }
    if(!is.null(x$corr)) {
    cat("\nCorrelations\n")
    print.default(format(x$corr, digits = digits), print.gap = 2, 
        quote = FALSE)
    }
    cat("\nOptimization Information\n")
    cat("  Convergence:", x$convergence, "\n")
    cat("  Function Evaluations:", x$counts["function"], "\n")
    if(!is.na(x$counts["gradient"]))
        cat("  Gradient Evaluations:", x$counts["gradient"], "\n")
    if(!is.null(x$message)) cat("  Message:", x$message, "\n")
    cat("\n")
    invisible(x)
}

"qq.pot" <-  function(x, ci = TRUE, main = "Quantile Plot", xlab = "Model", ylab = "Empirical", ...)
{
    quant <- qgpd(ppoints(x$nhigh), loc = x$threshold,
                 scale = x$scale, shape = x$param["shape"])
    if(!ci) {
      plot(quant, sort(x$exceedances), main = main, xlab = xlab,
           ylab = ylab, ...)
      abline(0, 1)
    }
    else {
      samp <- rgpd(x$nhigh*99, loc = x$threshold,
                 scale = x$scale, shape = x$param["shape"])
      samp <- matrix(samp, x$nhigh, 99)
      samp <- apply(samp, 2, sort)
      samp <- apply(samp, 1, sort)
      env <- t(samp[c(3,97),])
      rs <- sort(x$exceedances)
      matplot(quant, cbind(rs,env), main = main, xlab = xlab, ylab = ylab,
              type = "pnn", pch = 4, ...)
      xyuser <- par("usr")
      smidge <- min(diff(c(xyuser[1], quant, xyuser[2])))/2
      segments(quant-smidge, env[,1], quant+smidge, env[,1])
      segments(quant-smidge, env[,2], quant+smidge, env[,2])
      abline(0, 1)
    }
    invisible(list(x = quant, y = sort(x$exceedances)))
}

"pp.pot" <-  function(x, ci = TRUE, main = "Probability Plot", xlab = "Empirical", ylab = "Model", ...)
{
    ppx <- ppoints(x$nhigh)
    probs <- pgpd(sort(x$exceedances), loc = x$threshold,
                 scale = x$scale, shape = x$param["shape"])
    if(!ci) {
        plot(ppx, probs, main = main, xlab = xlab, ylab = ylab, ...)
        abline(0, 1)
    }
    else {
        samp <- rgpd(x$nhigh*99, loc = x$threshold,
                   scale = x$scale, shape = x$param["shape"])
        samp <- matrix(samp, x$nhigh, 99)
        samp <- apply(samp, 2, sort)
        samp <- apply(samp, 1, sort)
        env <- t(samp[c(3,97),])
        env[,1] <- pgpd(env[,1], loc = x$threshold,
                    scale = x$scale, shape = x$param["shape"])
        env[,2] <- pgpd(env[,2], loc = x$threshold,
                    scale = x$scale, shape = x$param["shape"])
        matplot(ppx, cbind(probs, env), main = main, xlab = xlab,
                ylab = ylab, type = "pnn", pch = 4, ...)
        xyuser <- par("usr")
        smidge <- min(diff(c(xyuser[1], ppx, xyuser[2])))/2
        segments(ppx-smidge, env[,1], ppx+smidge, env[,1])
        segments(ppx-smidge, env[,2], ppx+smidge, env[,2])
        abline(0, 1)
    }
    invisible(list(x = ppoints(x$nhigh), y = probs))
}

"rl.pot" <- function(x, ci = TRUE, main = "Return Level Plot", xlab = "Return Period", ylab = "Return Level", ...)
{
    rpstmfc <- c(1.001,10^(seq(0,3,len=200))[-1])
    rlev <- qgpd(1/rpstmfc, loc = x$threshold, scale = x$scale,
              shape = x$param["shape"], lower.tail = FALSE)
    mfc <- x$npp * x$nhigh/length(x$data)
    rps <- rpstmfc/mfc
    ppx <- 1/(mfc * (1 - ppoints(x$nhigh)))
    if(!ci) {
        plot(ppx, sort(x$exceedances), log = "x", main =
             main, xlab = xlab, ylab = ylab, ...)
        lines(rps, rlev)
    }
    else {
        samp <- rgpd(x$nhigh*99, loc = x$threshold,
                   scale = x$scale, shape = x$param["shape"])
        samp <- matrix(samp, x$nhigh, 99)
        samp <- apply(samp, 2, sort)
        samp <- apply(samp, 1, sort)
        env <- t(samp[c(3,97),])
        rs <- sort(x$exceedances)
        matplot(ppx, cbind(rs,env), main = main, xlab = xlab,
                ylab = ylab, type = "pnn", pch = 4, log = "x", ...)
        lines(rps, rlev)
        xyuser <- par("usr")
        smidge <- min(diff(c(xyuser[1], log10(ppx), xyuser[2])))/2
        segments(ppx*exp(-smidge), env[,1], ppx*exp(smidge), env[,1])
        segments(ppx*exp(-smidge), env[,2], ppx*exp(smidge), env[,2])
    }
    invisible(list(x = rps, y = rlev))
}

"dens.pot" <-  function(x, adjust = 1, nplty = 2, jitter = FALSE, main = "Density Plot", xlab = "Quantile", ylab = "Density", ...)
{
    xlimit <- range(x$exceedances)
    xlimit[2] <- xlimit[2] + diff(xlimit) * 0.075
    xvec <- seq(xlimit[1], xlimit[2], length = 100)
    dens <- dgpd(xvec, loc = x$threshold, scale = x$scale,
                shape = x$param["shape"])
    plot(spline(xvec, dens), main = main, xlab = xlab, ylab = ylab,
         type = "l", ...)
    if(jitter) rug(jitter(x$exceedances))
    else rug(x$exceedances)
    flipexceed <- c(x$exceedances, 2*x$threshold - x$exceedances)
    flipdens <- density(flipexceed, adjust = adjust, from = xlimit[1],
        to = xlimit[2])
    flipdens$y <- 2*flipdens$y
    lines(flipdens, lty = nplty)
    invisible(list(x = xvec, y = dens))
}

"clusters"<-
function(data, u, r = 1, ulow = -Inf, rlow = 1, cmax = FALSE, keep.names = TRUE,
    plot = FALSE, xdata = seq(along = data), lvals = TRUE, lty = 1, lwd = 1,
    pch = par("pch"), col = if(n > 250) NULL else "grey", xlab = "Index",
    ylab = "Data", ...)
{
    n <- length(data)
    if(length(u) != 1) u <- rep(u, length.out = n)
    if(length(ulow) != 1) ulow <- rep(ulow, length.out = n)
    if(any(ulow > u)) stop("`u' cannot be less than `ulow'")
    if(is.null(names(data)) && keep.names) names(data) <- 1:n
    if(!keep.names) names(data) <- NULL
    high <- as.double((data > u) & !is.na(data))
    high2 <- as.double((data > ulow) | is.na(data))
    clstrs <- .C("clusters", high, high2, n, as.integer(r),
        as.integer(rlow), clstrs = double(3*n), PACKAGE = "evd")$clstrs
    clstrs <- matrix(clstrs, n, 3)
    start <- clstrs[,2] ; end <- clstrs[,3]
    splvec <- clstrs[,1]
    start <- as.logical(start)
    end <- as.logical(end)
    clstrs <- split(data, splvec)
    names(clstrs) <- paste("cluster", names(clstrs), sep = "")
    if(any(!splvec)) clstrs <- clstrs[-1]
    nclust <- length(clstrs)
    acs <- sum(high)/nclust
    if(plot) {
      if(length(xdata) != length(data))
        stop("`xdata' and `data' have different lengths")
      if(any(is.na(xdata)))
        stop("`xdata' cannot contain missing values")
      if(any(duplicated(xdata)))
        stop("`xdata' cannot contain duplicated values")
      eps <- min(diff(xdata))/2
      start <- xdata[start] - eps
      end <- xdata[end] + eps
      plot(xdata, data, xlab = xlab, ylab = ylab, type = "n", ...)
      if(!is.null(col)) {
        for(i in 1:nclust) {
          xvl <- c(start[i], end[i], end[i], start[i])
          polygon(xvl, rep(par("usr")[3:4], each = 2), col = col)
        }
      }
      if(length(u) == 1) abline(h = u, lty = lty, lwd = lwd)
      else lines(xdata, u, lty = lty, lwd = lwd)
      if(lvals) {
        if(length(ulow) == 1) abline(h = ulow, lty = lty, lwd = lwd)
        else lines(xdata, ulow, lty = lty, lwd = lwd)
      }
      else {
        high <- as.logical(high)
        xdata <- xdata[high]
        data <- data[high]
      }
      points(xdata, data, pch = pch)
    }
    if(cmax) {
      if(keep.names)
        nmcl <- unlist(lapply(clstrs, function(x) names(x)[which.max(x)]))
      clstrs <- as.numeric(unlist(lapply(clstrs, max, na.rm = TRUE)))
      if(keep.names) names(clstrs) <- nmcl 
    }
    attributes(clstrs)$acs <- acs
    if(plot) return(invisible(clstrs))   
    clstrs
}

"exi"<-
function(data, u, r = 1, ulow = rep(-Inf, ncol(u)), rlow = rep(1, length(r)),
         dimnames = list(NULL, NULL), drop = TRUE)
{
    if(!is.matrix(u)) u <- t(as.matrix(u))
    if(!is.matrix(ulow)) ulow <- t(as.matrix(ulow))
    if(ncol(u) != ncol(ulow)) stop("`u' and `ulow' are not compatible")
    if(length(r) != length(rlow)) stop("`r' and `rlow' are not compatible")
    n <- ncol(u) ; m <- length(r)
    mat <- matrix(0, n, m, dimnames = dimnames)
    for(i in 1:n) {
       for(j in 1:m) {
          clstrs <- clusters(data, u = u[,i], r = r[j], ulow = ulow[,i],
            rlow = rlow[j], keep.names = FALSE)
          mat[i, j] <- attributes(clstrs)$acs
       }
    }
    if(drop) mat <- drop(mat)
    1/mat
}


"rfrechet"<-
function(n, loc = 0, scale = 1, shape = 1)
{
    if(min(scale) < 0 || min(shape) <= 0) stop("invalid arguments")
    loc + scale * rexp(n)^(-1/shape)
}

"rgumbel"<-
function(n, loc = 0, scale = 1)
{
    rgev(n, loc = loc, scale = scale, shape = 0)
}

"rrweibull"<-
function(n, loc = 0, scale = 1, shape = 1)
{
    if(min(scale) < 0 || min(shape) <= 0) stop("invalid arguments")
    loc - scale * rexp(n)^(1/shape)
}

"rgev"<-
function(n, loc = 0, scale = 1, shape = 0)
{
    if(min(scale) < 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    if(shape == 0) return(loc - scale * log(rexp(n)))
    else return(loc + scale * (rexp(n)^(-shape) - 1)/shape)
}

"rorder"<-
function(n, quantfun, ..., distn,  mlen = 1, j = 1, largest = TRUE)
{
    if(mode(mlen) != "numeric" || length(mlen) != 1 || mlen < 1 ||
       mlen %% 1 != 0) 
        stop("`mlen' must be a non-negative integer")
    if(mode(j) != "numeric" || length(j) != 1 || j < 1 || j %% 1 != 0) 
        stop("`j' must be a non-negative integer")
    if(j > mlen)
        stop("`j' cannot be greater than `mlen'")
    if(!largest) j <- mlen+1-j
    if(missing(quantfun))
        quantfun <- get(paste("q", distn, sep=""), mode="function")
    quantfun(rbeta(n, mlen+1-j, j), ...)
}

"rextreme"<-
function(n, quantfun, ..., distn, mlen = 1, largest = TRUE)
{
    if(mode(mlen) != "numeric" || length(mlen) != 1 || mlen < 1 ||
       mlen %% 1 != 0) 
        stop("`mlen' must be a non-negative integer")
    if(missing(quantfun))
        quantfun <- get(paste("q", distn, sep=""), mode="function")
    if(largest)
        quantfun(rbeta(n, mlen, 1), ...)
    else
        quantfun(rbeta(n, 1, mlen), ...) 
}

"qfrechet"<-
function(p, loc = 0, scale = 1, shape = 1, lower.tail = TRUE)
{
    if(min(p, na.rm = TRUE) <= 0 || max(p, na.rm = TRUE) >=1)
        stop("`p' must contain probabilities in (0,1)")
    if(min(scale) < 0 || min(shape) <= 0) stop("invalid arguments")
    if(!lower.tail) p <- 1 - p
    loc + scale * (-log(p))^(-1/shape)
}

"qgumbel"<-
function(p, loc = 0, scale = 1, lower.tail = TRUE)
{
    qgev(p, loc = loc, scale = scale, shape = 0, lower.tail = lower.tail)
}

"qrweibull"<-
function(p, loc = 0, scale = 1, shape = 1, lower.tail = TRUE)
{
    if(min(p, na.rm = TRUE) <= 0 || max(p, na.rm = TRUE) >=1)
        stop("`p' must contain probabilities in (0,1)")
    if(min(scale) < 0 || min(shape) <= 0) stop("invalid arguments")
    if(!lower.tail) p <- 1 - p
    loc - scale * (-log(p))^(1/shape)
}

"qgev"<-
function(p, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
{
    if(min(p, na.rm = TRUE) <= 0 || max(p, na.rm = TRUE) >=1)
        stop("`p' must contain probabilities in (0,1)")
    if(min(scale) < 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    if(!lower.tail) p <- 1 - p
    if(shape == 0) return(loc - scale * log(-log(p)))
    else return(loc + scale * ((-log(p))^(-shape) - 1)/shape)
}

"qextreme"<-
function(p, quantfun, ..., distn, mlen = 1, largest = TRUE, lower.tail = TRUE)
{
    if(min(p, na.rm = TRUE) <= 0 || max(p, na.rm = TRUE) >=1)
        stop("`p' must contain probabilities in (0,1)")
    if(mode(mlen) != "numeric" || length(mlen) != 1 || mlen < 1 ||
       mlen %% 1 != 0) 
        stop("`mlen' must be a non-negative integer")
    if(missing(quantfun))
        quantfun <- get(paste("q", distn, sep=""), mode="function")
    if(!lower.tail) p <- 1 - p
    if(largest) 
        quantfun(p^(1/mlen), ...)
    else
        quantfun(1-(1-p)^(1/mlen), ...)
}

"pfrechet"<-
function(q, loc = 0, scale = 1, shape = 1, lower.tail = TRUE)
{
    if(min(scale) <= 0 || min(shape) <= 0) stop("invalid arguments")
    q <- pmax((q - loc)/scale,0)
    p <- exp(-q^(-shape))
    if(!lower.tail) p <- 1 - p
    p
}

"pgumbel"<-
function(q, loc = 0, scale = 1, lower.tail = TRUE)
{
    pgev(q, loc = loc, scale = scale, shape = 0, lower.tail = lower.tail)
}

"prweibull"<-
function(q, loc = 0, scale = 1, shape = 1, lower.tail = TRUE)
{
    if(min(scale) <= 0 || min(shape) <= 0) stop("invalid arguments")
    q <- pmin((q - loc)/scale,0)
    p <- exp(-(-q)^shape)
    if(!lower.tail) p <- 1 - p
    p
}

"pgev"<-
function(q, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
{
    if(min(scale) <= 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    q <- (q - loc)/scale
    if(shape == 0) p <- exp(-exp(-q))
    else p <- exp( - pmax(1 + shape * q, 0)^(-1/shape))
    if(!lower.tail) p <- 1 - p
    p
}

"porder"<-
function(q, distnfun, ..., distn, mlen = 1, j = 1, largest = TRUE,
         lower.tail = TRUE)
{
    if(mode(mlen) != "numeric" || length(mlen) != 1 || mlen < 1 ||
       mlen %% 1 != 0) 
        stop("`mlen' must be a non-negative integer")
    if(mode(j) != "numeric" || length(j) != 1 || j < 1 || j %% 1 != 0) 
        stop("`j' must be a non-negative integer")
    if(j > mlen)
        stop("`j' cannot be greater than `mlen'")
    lachooseb <- function(a,b) lgamma(a+1) - lgamma(b+1) - lgamma(a-b+1)
    if(largest) svec <- (mlen+1-j):mlen
    else  svec <- 0:(j-1)
    if(missing(distnfun))
        distnfun <- get(paste("p", distn, sep=""), mode="function")
    distn <- distnfun(q, ...)
    store <- matrix(0,nrow=length(q),ncol=j)
    for(k in 1:j)
        store[,k] <- exp(lachooseb(mlen,svec[k]) + svec[k]*log(distn) +
                         (mlen-svec[k])*log(1-distn))
    p <- apply(store,1,sum)
    if(largest != lower.tail) p <- 1 - p
    p
}

"pextreme"<-
function(q, distnfun, ..., distn, mlen = 1, largest = TRUE, lower.tail = TRUE)
{
    if(mode(mlen) != "numeric" || length(mlen) != 1 || mlen < 1 ||
       mlen %% 1 != 0) 
        stop("`mlen' must be a non-negative integer")
    if(missing(distnfun))
        distnfun <- get(paste("p", distn, sep=""), mode="function")
    distn <- distnfun(q, ...)
    if(!largest) distn <- 1-distn
    p <- distn^mlen
    if(largest != lower.tail) p <- 1 - p
    p
}

"dfrechet"<-
function(x, loc = 0, scale = 1, shape = 1, log = FALSE)
{
    if(min(scale) <= 0 || min(shape) <= 0) stop("invalid arguments")
    x <- (x - loc)/scale
    xpos <- x[x>0 | is.na(x)]
    nn <- length(x)
    scale <- rep(scale, length.out = nn)[x>0 | is.na(x)]
    shape <- rep(shape, length.out = nn)[x>0 | is.na(x)]
    d <- numeric(nn)
    d[x>0 | is.na(x)] <- log(shape/scale) - (1+shape) * log(xpos) -
         xpos^(-shape)
    d[x<=0 & !is.na(x)] <- -Inf
    if(!log) d <- exp(d)
    d
}

"dgumbel"<-
function(x, loc = 0, scale = 1, log = FALSE)
{
    dgev(x, loc = loc, scale = scale, shape = 0, log = log)
}

"drweibull"<-
function(x, loc = 0, scale = 1, shape = 1, log = FALSE)
{
    if(min(scale) <= 0 || min(shape) <= 0) stop("invalid arguments")
    x <- (x - loc)/scale
    xneg <- x[x<0 | is.na(x)]
    nn <- length(x)
    scale <- rep(scale, length.out = nn)[x<0 | is.na(x)]
    shape <- rep(shape, length.out = nn)[x<0 | is.na(x)]
    d <- numeric(nn)
    d[x<0 | is.na(x)] <- log(shape/scale) + (shape-1) * log(-xneg) -
        (-xneg)^shape
    d[x>=0 & !is.na(x)] <- -Inf
    if(!log) d <- exp(d)
    d
}

"dgev"<-
function(x, loc = 0, scale = 1, shape = 0, log = FALSE)
{
    if(min(scale) <= 0) stop("invalid scale")
    if(length(shape) != 1) stop("invalid shape")
    x <- (x - loc)/scale
    if(shape == 0)
        d <- log(1/scale) - x - exp(-x) 
    else {
        nn <- length(x)
        xx <- 1 + shape*x
        xxpos <- xx[xx>0 | is.na(xx)]
        scale <- rep(scale, length.out = nn)[xx>0 | is.na(xx)]
        d <- numeric(nn)
        d[xx>0 | is.na(xx)] <- log(1/scale) - xxpos^(-1/shape) -
            (1/shape + 1)*log(xxpos)
        d[xx<=0 & !is.na(xx)] <- -Inf
    }  
    if(!log) d <- exp(d)
    d
}

"dorder"<-
function(x, densfun, distnfun, ..., distn, mlen = 1, j = 1, largest = TRUE,
         log = FALSE)
{
    if(mode(mlen) != "numeric" || length(mlen) != 1 || mlen < 1 ||
       mlen %% 1 != 0) 
        stop("`mlen' must be a non-negative integer")
    if(mode(j) != "numeric" || length(j) != 1 || j < 1 || j %% 1 != 0) 
        stop("`j' must be a non-negative integer")
    if(j > mlen)
        stop("`j' cannot be greater than `mlen'")
    if(!largest) j <- mlen + 1 - j
    if(missing(densfun))
        densfun <- get(paste("d", distn, sep=""), mode="function")
    if(missing(distnfun))
        distnfun <- get(paste("p", distn, sep=""), mode="function")
    dens <- densfun(x, ..., log = TRUE)
    distn <- distnfun(x, ...)[!is.infinite(dens)]
    distn <- (mlen-j) * log(distn) + (j-1) * log(1-distn)
    comb <- lgamma(mlen+1) - lgamma(j) - lgamma(mlen-j+1)
    d <- numeric(length(x))
    d[!is.infinite(dens)] <- comb + dens[!is.infinite(dens)] + distn
    d[is.infinite(dens)] <- -Inf
    if(!log) d <- exp(d)
    d
}

"dextreme"<-
function(x, densfun, distnfun, ..., distn, mlen = 1, largest = TRUE, log = FALSE)
{
    if(mode(mlen) != "numeric" || length(mlen) != 1 || mlen < 1 ||
       mlen %% 1 != 0) 
        stop("`mlen' must be a non-negative integer")
    if(!largest) j <- mlen + 1 - j
    if(missing(densfun))
        densfun <- get(paste("d", distn, sep=""), mode="function")
    if(missing(distnfun))
        distnfun <- get(paste("p", distn, sep=""), mode="function")
    dens <- densfun(x, ..., log = TRUE)
    distn <- distnfun(x, ...)[!is.infinite(dens)]
    if(!largest) distn <- 1 - distn
    distn <- (mlen-1) * log(distn)
    d <- numeric(length(x))
    d[!is.infinite(dens)] <- log(mlen) + dens[!is.infinite(dens)] + distn
    d[is.infinite(dens)] <- -Inf
    if(!log) d <- exp(d)
    d
}

"fextreme"<-
function(x, start, densfun, distnfun, ..., distn, mlen = 1, largest = TRUE,
         std.err = TRUE, corr = FALSE, method = "Nelder-Mead")
{
    if (missing(x) || length(x) == 0 || mode(x) != "numeric") 
        stop("`x' must be a non-empty numeric object")
    if(any(is.na(x)))
        stop("`x' must not contain missing values")
    if (!is.list(start)) 
        stop("`start' must be a named list")
    call <- match.call()
    if(missing(densfun))
        densfun <- get(paste("d", distn, sep=""), mode="function")
    if(missing(distnfun))
        distnfun <- get(paste("p", distn, sep=""), mode="function")
    nllh <- function(p, ...) {
        dvec <- dens(p, ..., log = TRUE)
        if(any(is.infinite(dvec)))
            return(1e6)
        else 
            return(-sum(dvec))
    }
    nm <- names(start)
    l <- length(nm)
    f1 <- formals(densfun)
    f2 <- formals(distnfun)
    args <- names(f1)
    mtch <- match(nm, args)
    if (any(is.na(mtch))) 
        stop("`start' specifies unknown arguments")
    formals(densfun) <- c(f1[c(1, mtch)], f1[-c(1, mtch)])
    formals(distnfun) <- c(f2[c(1, mtch)], f2[-c(1, mtch)])
    dens <- function(p, x, densfun, distnfun, ...)
                dextreme(x, densfun, distnfun, p, ...)
    if(l > 1)
        body(dens) <- parse(text = paste("dextreme(x, densfun, distnfun,",
                            paste("p[",1:l,"]", collapse = ", "), ", ...)"))
    opt <- optim(start, nllh, x = x, hessian = TRUE, ...,
                 densfun = densfun, distnfun = distnfun, mlen = mlen,
                 largest = largest, method = method)
    if (opt$convergence != 0) {
        warning("optimization may not have succeeded")
        if(opt$convergence == 1) opt$convergence <- "iteration limit reached"
    }
    else opt$convergence <- "successful"
    if(std.err) {
        tol <- .Machine$double.eps^0.5
        var.cov <- qr(opt$hessian, tol = tol)
        if (var.cov$rank != ncol(var.cov$qr)) 
            stop("observed information matrix is singular; use std.err = FALSE")
        var.cov <- solve(var.cov, tol = tol)
        std.err <- diag(var.cov)
        if(any(std.err <= 0))
            stop("observed information matrix is singular; use std.err = FALSE")
        std.err <- sqrt(std.err)
        names(std.err) <- nm
        if(corr) {
            .mat <- diag(1/std.err, nrow = length(std.err))
            corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm,nm))
            diag(corr) <- rep(1, length(std.err))
        }
        else corr <- NULL
    }
    else std.err <- corr <- NULL
    structure(list(estimate = opt$par, std.err = std.err,
        deviance = 2*opt$value, corr = corr,
        convergence = opt$convergence, counts = opt$counts,
        message = opt$message, call = call, data = x,
        n = length(x)), class = c("extreme", "evd"))
}

"forder"<-
function(x, start, densfun, distnfun, ..., distn, mlen = 1, j = 1,
         largest = TRUE, std.err = TRUE, corr = FALSE, method = "Nelder-Mead")
{
    if (missing(x) || length(x) == 0 || mode(x) != "numeric") 
        stop("`x' must be a non-empty numeric object")
    if(any(is.na(x)))
        stop("`x' must not contain missing values")
    if (!is.list(start)) 
        stop("`start' must be a named list")
    call <- match.call()
    if(missing(densfun))
        densfun <- get(paste("d", distn, sep=""), mode="function")
    if(missing(distnfun))
        distnfun <- get(paste("p", distn, sep=""), mode="function")
    nllh <- function(p, ...) {
        dvec <- dens(p, ..., log = TRUE)
        if(any(is.infinite(dvec)))
            return(1e6)
        else 
            return(-sum(dvec))
    }
    nm <- names(start)
    l <- length(nm)
    f1 <- formals(densfun)
    f2 <- formals(distnfun)
    args <- names(f1)
    mtch <- match(nm, args)
    if (any(is.na(mtch))) 
        stop("`start' specifies unknown arguments")
    formals(densfun) <- c(f1[c(1, mtch)], f1[-c(1, mtch)])
    formals(distnfun) <- c(f2[c(1, mtch)], f2[-c(1, mtch)])
    dens <- function(p, x, densfun, distnfun, ...)
                dorder(x, densfun, distnfun, p, ...)
    if(l > 1)
        body(dens) <- parse(text = paste("dorder(x, densfun, distnfun,",
                            paste("p[",1:l,"]", collapse = ", "), ", ...)"))
    opt <- optim(start, nllh, x = x, hessian = TRUE, ..., densfun = densfun,
                 distnfun = distnfun, mlen = mlen, j = j, largest = largest,
                 method = method)
    if (opt$convergence != 0) {
        warning("optimization may not have succeeded")
        if(opt$convergence == 1) opt$convergence <- "iteration limit reached"
    }
    else opt$convergence <- "successful"
    if(std.err) {
        tol <- .Machine$double.eps^0.5
        var.cov <- qr(opt$hessian, tol = tol)
        if (var.cov$rank != ncol(var.cov$qr)) 
            stop("observed information matrix is singular; use std.err = FALSE")
        var.cov <- solve(var.cov, tol = tol)
        std.err <- diag(var.cov)
        if(any(std.err <= 0))
            stop("observed information matrix is singular; use std.err = FALSE")
        std.err <- sqrt(std.err)
        names(std.err) <- nm
        if(corr) {
            .mat <- diag(1/std.err, nrow = length(std.err))
            corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm,nm))
            diag(corr) <- rep(1, length(std.err))
        }
        else corr <- NULL
    }
    else std.err <- corr <- NULL
    names(std.err) <- nm
    structure(list(estimate = opt$par, std.err = std.err,
        deviance = 2*opt$value, corr = corr,
        convergence = opt$convergence, counts = opt$counts,
        message = opt$message, call = call, data = x,
        n = length(x)), class = c("extreme", "evd"))
}

"fgev.norm"<-
function(x, start, ..., nsloc = NULL, std.err = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlgev <- function(loc, scale, shape)
    { 
        if(scale <= 0) return(1e6)
        if(!is.null(nsloc)) {
            ns <- numeric(length(loc.param))
            for(i in 1:length(ns))
                ns[i] <- get(loc.param[i])
            loc <- drop(nslocmat %*% ns)
        }
        else loc <- rep(loc, length.out = length(x))
        .C("nlgev",
            x, n, loc, scale, shape, dns = double(1),
            PACKAGE = "evd")$dns
    }
    if(!is.null(nsloc)) {
        nsloc <- nsloc.transform(x, nsloc)
        nsloc <- nsloc[!is.na(x), ,drop = FALSE]
        nslocmat <- cbind(1,as.matrix(nsloc))
    }
    x <- as.double(x[!is.na(x)])
    n <- as.integer(length(x))
    loc.param <- paste("loc", c("",names(nsloc)), sep="")
    param <- c(loc.param, "scale", "shape")
    if(missing(start)) {
        start <- as.list(numeric(length(param)))
        names(start) <- param
        start$scale <- sqrt(6 * var(x))/pi
        start$loc <- mean(x) - 0.58 * start$scale
        start <- start[!(param %in% names(list(...)))]
    }
    if(!is.list(start)) 
        stop("`start' must be a named list")
    if(!length(start))
        stop("there are no parameters left to maximize over")
    nm <- names(start)
    l <- length(nm)
    f <- c(as.list(numeric(length(loc.param))), formals(nlgev)[2:3])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlgev) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlgev(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlgev(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    fixed.param <- list(...)[names(list(...)) %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    if (opt$convergence != 0) {
        warning("optimization may not have succeeded")
        if(opt$convergence == 1) opt$convergence <- "iteration limit reached"
    }
    else opt$convergence <- "successful"
    if(std.err) {
        tol <- .Machine$double.eps^0.5
        var.cov <- qr(opt$hessian, tol = tol)
        if(var.cov$rank != ncol(var.cov$qr)) 
            stop("observed information matrix is singular; use std.err = FALSE")
        var.cov <- solve(var.cov, tol = tol)
        std.err <- diag(var.cov)
        if(any(std.err <= 0))
            stop("observed information matrix is singular; use std.err = FALSE")
        std.err <- sqrt(std.err)
        names(std.err) <- nm
        if(corr) {
            .mat <- diag(1/std.err, nrow = length(std.err))
            corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm,nm))
            diag(corr) <- rep(1, length(std.err))
        }
        else corr <- NULL
    }
    else std.err <- corr <- NULL
    param <- c(opt$par, unlist(fixed.param))
    if(!is.null(nsloc)) {
        trend <- param[paste("loc", names(nsloc), sep="")]
        trend <- drop(as.matrix(nsloc) %*% trend)
        x2 <- x - trend
    }
    else x2 <- x
    list(estimate = opt$par, std.err = std.err,
        fixed = unlist(fixed.param), param = param,
        deviance = 2*opt$value, corr = corr,
        convergence = opt$convergence, counts = opt$counts,
        message = opt$message,
        data = x, tdata = x2, nsloc = nsloc,
        n = length(x), prob = NULL, loc = param["loc"])
}

"fgev.quantile"<-
function(x, start, ..., nsloc = NULL, prob, std.err = TRUE, corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
    nlgev <- function(quantile, scale, shape)
    {
        if(scale <= 0) return(1e6)
        quantile <- rep(quantile, length.out = length(x))
        if(prob == 0 && shape >= 0) return(1e6)
        if(prob == 1 && shape <= 0) return(1e6)
        if(shape == 0) loc <- quantile + scale * log(-log(1-prob))
        else loc <- quantile + scale/shape * (1 - (-log(1-prob))^(-shape))
        if(!is.null(nsloc)) {
            ns <- numeric(length(loc.param) - 1)
            for(i in 1:length(ns))
                ns[i] <- get(loc.param[i+1])
            loc <- drop(nslocmat %*% ns) + loc
        }
        if(any(is.infinite(loc))) return(1e6)
        .C("nlgev",
            x, n,
            loc, scale, shape, dns = double(1),
            PACKAGE = "evd")$dns
    }
    if(is.null(nsloc)) loc.param <- "quantile"
    else loc.param <- c("quantile", paste("loc", names(nsloc), sep=""))
    param <- c(loc.param, "scale", "shape")
    if(missing(start)) {
        start <- as.list(numeric(length(param)))
        names(start) <- param
        start$scale <- sqrt(6 * var(x, na.rm = TRUE))/pi
        start.loc <- mean(x, na.rm = TRUE) - 0.58 * start$scale
        start$quantile <- start.loc - start$scale * log(-log(1-prob))
        if(prob == 0) {
          fpft <- fgev(x = x, ..., nsloc = nsloc, prob = 0.001, std.err =
            std.err, corr = corr, method = method, warn.inf = warn.inf)
          start <- as.list(fitted(fpft))
        }
        if(prob == 1) {
          fpft <- fgev(x = x, ..., nsloc = nsloc, prob = 0.999, std.err =
            std.err, corr = corr, method = method, warn.inf = warn.inf)
          start <- as.list(fitted(fpft))
        }
        start <- start[!(param %in% names(list(...)))]
    }
    if(!is.list(start)) 
        stop("`start' must be a named list")
    if(!length(start))
        stop("there are no parameters left to maximize over")
    if(!is.null(nsloc)) {
        nsloc <- nsloc.transform(x, nsloc)
        nsloc <- nsloc[!is.na(x), ,drop = FALSE]
        nslocmat <- as.matrix(nsloc)
    }
    x <- as.double(x[!is.na(x)])
    n <- as.integer(length(x))
    nm <- names(start)
    l <- length(nm)
    f <- c(as.list(numeric(length(loc.param))), formals(nlgev)[2:3])
    names(f) <- param
    m <- match(nm, param)
    if(any(is.na(m))) 
        stop("`start' specifies unknown arguments")    
    formals(nlgev) <- c(f[m], f[-m])
    nllh <- function(p, ...) nlgev(p, ...)
    if(l > 1)
        body(nllh) <- parse(text = paste("nlgev(", paste("p[",1:l,
            "]", collapse = ", "), ", ...)"))
    fixed.param <- list(...)[names(list(...)) %in% param]
    if(any(!(param %in% c(nm,names(fixed.param)))))
        stop("unspecified parameters")
    start.arg <- c(list(p = unlist(start)), fixed.param)
    if(warn.inf && do.call("nllh", start.arg) == 1e6)
        warning("negative log-likelihood is infinite at starting values")
    opt <- optim(start, nllh, hessian = TRUE, ..., method = method)
    if (opt$convergence != 0) {
        warning("optimization may not have succeeded")
        if(opt$convergence == 1) opt$convergence <- "iteration limit reached"
    }
    else opt$convergence <- "successful"
    if(std.err) {
        tol <- .Machine$double.eps^0.5
        var.cov <- qr(opt$hessian, tol = tol)
        if(var.cov$rank != ncol(var.cov$qr)) 
            stop("observed information matrix is singular; use std.err = FALSE")
        var.cov <- solve(var.cov, tol = tol)
        std.err <- diag(var.cov)
        if(any(std.err <= 0))
            stop("observed information matrix is singular; use std.err = FALSE")
        std.err <- sqrt(std.err)
        names(std.err) <- nm
        .mat <- diag(1/std.err, nrow = length(std.err))
        if(corr) {
            corr <- structure(.mat %*% var.cov %*% .mat, dimnames = list(nm,nm))
            diag(corr) <- rep(1, length(std.err))
        }
        else corr <- NULL
    }
    else {
        std.err <- corr <- NULL
    }
    param <- c(opt$par, unlist(fixed.param))
    if(!is.null(nsloc)) {
        trend <- param[paste("loc", names(nsloc), sep="")]
        trend <- drop(as.matrix(nsloc) %*% trend)
        x2 <- x - trend
    }
    else x2 <- x
    if(param["shape"] == 0)
        loc <- param["quantile"] + param["scale"] * log(-log(1-prob))
    else
        loc <- param["quantile"] + param["scale"]/param["shape"] *
          (1 - (-log(1-prob))^(-param["shape"]))
    list(estimate = opt$par, std.err = std.err,
        fixed = unlist(fixed.param), param = param,
        deviance = 2*opt$value, corr = corr, convergence = opt$convergence,
        counts = opt$counts, message = opt$message,
        data = x, tdata = x2, nsloc = nsloc, n = length(x),
        prob = prob, loc = loc)
}

"fgev"<-
function(x, start, ..., nsloc = NULL, prob = NULL, std.err = TRUE,
    corr = FALSE, method = "BFGS", warn.inf = TRUE)
{
  call <- match.call()
  if(missing(x) || length(x) == 0 || mode(x) != "numeric") 
    stop("`x' must be a non-empty numeric vector")
  if(is.null(prob)) {
    ft <- fgev.norm(x = x, start = start, ..., nsloc = nsloc, std.err =
      std.err, corr = corr, method = method, warn.inf = warn.inf)
  }
  else {
    if(length(prob) != 1 || mode(prob) != "numeric" || prob < 0 || prob > 1)
      stop("`prob' should be a probability in [0,1]")
    ft <- fgev.quantile(x = x, start = start, ..., nsloc = nsloc, prob = prob,
      std.err = std.err, corr = corr, method = method, warn.inf = warn.inf)
  }
  structure(c(ft, call = call), class = c("gev", "uvevd", "evd"))
}

"print.evd" <-  function(x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:", deparse(x$call), "\n")
    cat("Deviance:", x$deviance, "\n")
    cat("\nEstimates\n")
    print.default(format(x$estimate, digits = digits), print.gap = 2, 
        quote = FALSE)
    if(!is.null(x$std.err)) {
    cat("\nStandard Errors\n")
    print.default(format(x$std.err, digits = digits), print.gap = 2, 
        quote = FALSE)
    }
    if(!is.null(x$corr)) {
    cat("\nCorrelations\n")
    print.default(format(x$corr, digits = digits), print.gap = 2, 
        quote = FALSE)
    }
    cat("\nOptimization Information\n")
    cat("  Convergence:", x$convergence, "\n")
    cat("  Function Evaluations:", x$counts["function"], "\n")
    if(!is.na(x$counts["gradient"]))
        cat("  Gradient Evaluations:", x$counts["gradient"], "\n")
    if(!is.null(x$message)) cat("  Message:", x$message, "\n")
    cat("\n")
    invisible(x)
}

"fitted.evd" <- function (object, ...) object$estimate
"std.errors" <- function (object, ...) UseMethod("std.errors")
"std.errors.evd" <- function (object, ...) object$std.err
"logLik.evd" <- function(object, ...) {
    val <- -deviance(object)/2
    attr(val, "df") <- length(fitted(object))
    class(val) <- "logLik"
    val
}

"anova.evd" <- function (object, object2, ...) 
{
    narg <- nargs()
    if(narg < 2) stop("there must be two or more arguments")
    dots <- as.list(substitute(list(...)))[-1]
    dots <- sapply(dots,function(x) deparse(x))
    if(!length(dots)) dots <- NULL
    model1 <- deparse(substitute(object))
    model2 <- deparse(substitute(object2))
    models <- c(model1, model2, dots)
    for(i in 1:narg) {
        if(!inherits(get(models[i]), "evd")) 
            stop("Use only with 'evd' objects")
    }
    for(i in 1:(narg-1)) {
        a <- names(get(models[i])$estimate)
        b <- names(get(models[i+1])$estimate)
        if(!all(b %in% a))
            stop("models are not nested")
    }
    dv <- npar <- numeric(narg)
    for(i in 1:narg) {
        dv[i] <- get(models[i])$deviance
        npar[i] <- length(get(models[i])$estimate)
    }
    df <- -diff(npar)
    if(any(df == 0)) stop("models are not nested")
    dvdiff <- diff(dv)
    if(any(dvdiff < 0)) stop("models are not nested")
    pval <- pchisq(dvdiff, df = df, lower.tail = FALSE)
    table <- data.frame(npar, dv, c(NA,df), c(NA,dvdiff), c(NA,pval))
    dimnames(table) <- list(models, c("M.Df", "Deviance", "Df", "Chisq",
                                      "Pr(>chisq)"))
    structure(table, heading = c("Analysis of Deviance Table\n"),
              class = c("anova", "data.frame"))
}

"plot.uvevd" <-  function(x, which = 1:4, main = c("Probability Plot",
     "Quantile Plot", "Density Plot", "Return Level Plot"),
     ask = nb.fig < length(which) && dev.interactive(), ci = TRUE,
     adjust = 1, jitter = FALSE, nplty = 2, ...) 
{
    if (!inherits(x, "uvevd")) 
        stop("Use only with `'uvevd objects")
    if (!is.numeric(which) || any(which < 1) || any(which > 4)) 
        stop("`which' must be in 1:4")
    show <- rep(FALSE, 4)
    show[which] <- TRUE
    nb.fig <- prod(par("mfcol"))
    if (ask) {
        op <- par(ask = TRUE)
        on.exit(par(op))
    }
    if (show[1]) {
        pp(x, ci = ci, main = main[1], xlim = c(0,1), ylim = c(0,1), ...)
    }
    if (show[2]) {
        qq(x, ci = ci, main = main[2], ...)
    }
    if (show[3]) {
        dens(x, adjust = adjust, nplty = nplty, jitter = jitter,
             main = main[3], ...)
    }
    if (show[4]) {
        rl(x, ci = ci, main = main[4], ...)
    }
    invisible(x)
}

"qq" <- function (x, ...) UseMethod("qq")
"pp" <- function (x, ...) UseMethod("pp")
"rl" <- function (x, ...) UseMethod("rl")
"dens" <- function (x, ...) UseMethod("dens")

"qq.gev" <-  function(x, ci = TRUE, main = "Quantile Plot", xlab = "Model", ylab = "Empirical", ...)
{
    quant <- qgev(ppoints(x$tdata), loc = x$loc,
                 scale = x$param["scale"], shape = x$param["shape"])
    if(!ci) {
      plot(quant, sort(x$tdata), main = main, xlab = xlab, ylab = ylab, ...)
      abline(0, 1)
    }
    else {
      samp <- rgev(x$n*99, loc = x$loc,
                 scale = x$param["scale"], shape = x$param["shape"])
      samp <- matrix(samp, x$n, 99)
      samp <- apply(samp, 2, sort)
      samp <- apply(samp, 1, sort)
      env <- t(samp[c(3,97),])
      rs <- sort(x$tdata)
      matplot(quant, cbind(rs,env), main = main, xlab = xlab, ylab = ylab,
              type = "pnn", pch = 4, ...)
      xyuser <- par("usr")
      smidge <- min(diff(c(xyuser[1], quant, xyuser[2])))/2
      segments(quant-smidge, env[,1], quant+smidge, env[,1])
      segments(quant-smidge, env[,2], quant+smidge, env[,2])
      abline(0, 1)
    }
    invisible(list(x = quant, y = sort(x$tdata)))
}

"pp.gev" <-  function(x, ci = TRUE, main = "Probability Plot", xlab = "Empirical", ylab = "Model", ...)
{
    ppx <- ppoints(x$n)
    probs <- pgev(sort(x$tdata), loc = x$loc,
                 scale = x$param["scale"], shape = x$param["shape"])
    if(!ci) {
        plot(ppx, probs, main = main, xlab = xlab, ylab = ylab, ...)
        abline(0, 1)
    }
    else {
        samp <- rgev(x$n*99, loc = x$loc,
                   scale = x$param["scale"], shape = x$param["shape"])
        samp <- matrix(samp, x$n, 99)
        samp <- apply(samp, 2, sort)
        samp <- apply(samp, 1, sort)
        env <- t(samp[c(3,97),])
        env[,1] <- pgev(env[,1], loc = x$loc,
                    scale = x$param["scale"], shape = x$param["shape"])
        env[,2] <- pgev(env[,2], loc = x$loc,
                    scale = x$param["scale"], shape = x$param["shape"])
        matplot(ppx, cbind(probs, env), main = main, xlab = xlab,
                ylab = ylab, type = "pnn", pch = 4, ...)
        xyuser <- par("usr")
        smidge <- min(diff(c(xyuser[1], ppx, xyuser[2])))/2
        segments(ppx-smidge, env[,1], ppx+smidge, env[,1])
        segments(ppx-smidge, env[,2], ppx+smidge, env[,2])
        abline(0, 1)
    }
    invisible(list(x = ppoints(x$n), y = probs))
}

"rl.gev" <-  function(x, ci = TRUE, main = "Return Level Plot", xlab = "Return Period", ylab = "Return Level", ...)
{
    ppx <- ppoints(x$tdata)
    rps <- c(1.001,10^(seq(0,3,len=200))[-1])
    p.upper <- 1/rps
    rlev <- qgev(p.upper, loc = x$loc, scale = x$param["scale"],
              shape = x$param["shape"], lower.tail = FALSE)
    if(!ci) {
        plot(-1/log(ppx), sort(x$tdata),log = "x", main = main,
             xlab = xlab, ylab = ylab, ...)
        lines(-1/log(1-p.upper), rlev)
    }
    else {
        samp <- rgev(x$n*99, loc = x$loc,
                   scale = x$param["scale"], shape = x$param["shape"])
        samp <- matrix(samp, x$n, 99)
        samp <- apply(samp, 2, sort)
        samp <- apply(samp, 1, sort)
        env <- t(samp[c(3,97),])
        rs <- sort(x$tdata)
        matplot(-1/log(ppx), cbind(rs,env), main = main, xlab = xlab,
                ylab = ylab, type = "pnn", pch = 4, log = "x", ...)
        lines(-1/log(1-p.upper), rlev)
        xyuser <- par("usr")
        smidge <- min(diff(c(xyuser[1], log10(-1/log(ppx)), xyuser[2])))/2
        segments((-1/log(ppx))*exp(-smidge), env[,1],
                 (-1/log(ppx))*exp(smidge), env[,1])
        segments((-1/log(ppx))*exp(-smidge), env[,2],
                 (-1/log(ppx))*exp(smidge), env[,2])
    }
    invisible(list(x = -1/log(1-p.upper), y = rlev))
}

"dens.gev" <-  function(x, adjust = 1, nplty = 2, jitter = FALSE, main = "Density Plot", xlab = "Quantile", ylab = "Density", ...)
{
    xlimit <- range(x$tdata)
    xlimit[1] <- xlimit[1] - diff(xlimit) * 0.075
    xlimit[2] <- xlimit[2] + diff(xlimit) * 0.075
    xvec <- seq(xlimit[1], xlimit[2], length = 100)
    dens <- dgev(xvec, loc = x$loc, scale = x$param["scale"],
                shape = x$param["shape"])
    plot(spline(xvec, dens), main = main, xlab = xlab, ylab = ylab,
         type = "l", ...)
    if(jitter) rug(jitter(x$tdata))
    else rug(x$tdata)
    lines(density(x$tdata, adjust = adjust), lty = nplty)
    invisible(list(x = xvec, y = dens))
}

"profile.evd" <-  function(fitted, which = names(fitted$estimate), conf = 0.999, mesh = fitted$std.err[which]/4, xmin = rep(-Inf, length(which)), xmax = rep(Inf, length(which)), convergence = FALSE, method = "BFGS", control = list(maxit = 500), ...)
{
    if(!inherits(fitted, "evd")) 
        stop("Use only with `evd' objects")
    if(inherits(fitted, "extreme"))
        stop("profiles not implemented for this model")
    if(length(xmin) != length(which))
        stop("`xmin' and `which' must have the same length")
    if(length(xmax) != length(which))
        stop("`xmax' and `which' must have the same length")
    if(length(fitted$estimate) < 2)
        stop("cannot profile one dimensional likelihood")
    if(!is.character(which))
        stop("`which' must be a character vector")
    if(!all(which %in% names(fitted$estimate)))
        stop("`which' contains unrecognized or unestimated parameters")
    if(is.null(fitted$std.err) && missing(mesh))
       stop("fitted model must contain standard errors")
    prof.list <- as.list(numeric(length(which)))
    names(xmin) <- names(xmax) <- names(prof.list) <- which
    if(is.null(names(mesh))) names(mesh) <- which
    mles <- fitted$estimate[which]                   
    for(j in which) {
        print(paste("profiling",j))
        prof1 <- prof2 <- matrix(nrow = 0, ncol = length(fitted$estimate) + 1)
        npmles <- fitted$estimate[!names(fitted$estimate) %in% j]
        start <- as.list(npmles)
        call.args <- c(list(fitted$data, start, 0), as.list(fitted$fixed),
           list(FALSE, FALSE, method, FALSE, control))
        names(call.args) <- c("x", "start", j, names(fitted$fixed),
           "std.err", "corr", "method", "warn.inf", "control")
        dimnames(prof1) <- dimnames(prof2) <- list(NULL, c(j, "deviance",
          names(start)))
        call.fn <- paste("f", class(fitted)[1], sep="")
        if(inherits(fitted, "gev")) {
            call.args$nsloc <- fitted$nsloc
            call.args$prob <- fitted$prob
        }
        if(inherits(fitted, "pot")) {
            call.args$threshold <- fitted$threshold
            call.args$npp <- fitted$npp
            call.args$period <- fitted$period
            call.args$cmax <- fitted$cmax
            call.args$r <- fitted$r
            call.args$ulow <- fitted$ulow
            call.args$rlow <- fitted$rlow
            call.args$mper <- fitted$mper
        }
        if(inherits(fitted, "bvevd")) {
            call.args$model <- fitted$model
            call.args$nsloc1 <- fitted$nsloc1
            call.args$nsloc2 <- fitted$nsloc2
            call.args$sym <- fitted$sym
            call.args$cloc <- fitted$cmar[1]
            call.args$cscale <- fitted$cmar[2]
            call.args$cshape <- fitted$cmar[3]
            call.args$dsm <- FALSE
        }
        if(inherits(fitted, "bvpot")) {
            call.args$threshold <- fitted$threshold
            call.args$likelihood <- fitted$likelihood
            call.args$model <- fitted$model
            call.args$sym <- fitted$sym
            call.args$cscale <- fitted$cmar[1]
            call.args$cshape <- fitted$cmar[2]
            call.args$dsm <- FALSE          
        }
        lcnt <- TRUE; ppar <- mles[j]
        while(lcnt) {
            ppar <- as.vector(ppar + mesh[j])
            if(ppar >= xmax[j]) ppar <- as.vector(xmax[j])      
            call.args[[j]] <- ppar
            fit.mod <- do.call(call.fn, call.args)
            if(convergence) print(fit.mod$convergence)
            call.args[["start"]] <- as.list(fit.mod$estimate)
            rop <- c(ppar, fit.mod$deviance, fit.mod$estimate)
            prof1 <- rbind(prof1, rop)
            ddf <- fit.mod$deviance - fitted$deviance
            lcnt <- (ddf <= qchisq(conf, 1)) && (ppar != xmax[j])
        }
        call.args[["start"]] <- as.list(npmles)
        lcnt <- TRUE; ppar <- mles[j]
        while(lcnt) {
            ppar <- as.vector(ppar - mesh[j])
            if(ppar <= xmin[j]) ppar <- as.vector(xmin[j])
            call.args[[j]] <- ppar
            fit.mod <- do.call(call.fn, call.args)
            if(convergence) print(fit.mod$convergence)
            call.args[["start"]] <- as.list(fit.mod$estimate)
            rop <- c(ppar, fit.mod$deviance, fit.mod$estimate)
            prof2 <- rbind(prof2, rop)
            ddf <- fit.mod$deviance - fitted$deviance
            lcnt <- (ddf <= qchisq(conf, 1)) && (ppar != xmin[j])
        }
        rop <- c(mles[j], fitted$deviance, npmles)
        prof2 <- prof2[nrow(prof2):1, ,drop = FALSE]
        prof <- rbind(prof2, rop, prof1)
        rownames(prof) <- NULL
        
        rdev <- qchisq(conf, 1) + fitted$deviance
        if(prof[1, "deviance"] == 2e6)  {
          prof <- prof[-1, ,drop = FALSE]
          if(prof[1,"deviance"] <= rdev)
            warning(paste("If", j, "is to satisfy `conf',",
              "`mesh' must be smaller"))
        }
        if(prof[nrow(prof), "deviance"] == 2e6) {
          prof <- prof[-nrow(prof), ,drop = FALSE]
          if(prof[nrow(prof),"deviance"] <= rdev)
            warning(paste("If", j, "is to satisfy `conf',",
              "`mesh' must be smaller"))
        }
        prof.list[[j]] <- prof
    }
    structure(prof.list, deviance = fitted$deviance,
              xmin = xmin, xmax = xmax, class = "profile.evd")
}

# Assumes profile trace is unimodal
"pcint" <- function(prof, which = names(prof), ci = 0.95)
{
    if (!inherits(prof, "profile.evd")) 
        stop("Use only with `profile.evd' objects")
    if(!is.character(which))
        stop("`which' must be a character vector")
    if(!all(which %in% names(prof)))
        stop("`which' contains unprofiled parameters")
    rdevs <- attributes(prof)$deviance + qchisq(ci, df = 1)
    civals <- as.list(which)
    names(civals) <- which
    for(i in which) {
      x <- prof[[i]]
      n <- nrow(x)
      ulim <- min(x[1,"deviance"],x[n,"deviance"])
      llim <- min(x[1,"deviance"],x[n,"deviance"])
      th.l <- x[1, i] == attributes(prof)$xmin[i]
      th.u <- x[n, i] == attributes(prof)$xmax[i]
      halves <- c(diff(x[,"deviance"]) < 0, FALSE)
      cisfi <- matrix(0, nrow = length(ci), ncol = 2, dimnames =
        list(ci, c("lower", "upper")))
      for(j in 1:length(ci)) {  
        if(x[1,"deviance"] <= rdevs[j] && !th.l) {
            warning(paste("cannot calculate lower confidence limit for", i))
            cisfi[j,1] <- NA
        }
        if(x[1,"deviance"] <= rdevs[j] && th.l) cisfi[j,1] <- x[1, i]
        if(x[1,"deviance"] > rdevs[j])
          cisfi[j,1] <- approx(x[halves,2], x[halves,1], xout = rdevs[j])$y
        if(x[n,"deviance"] <= rdevs[j] && !th.u) {
            warning(paste("cannot calculate upper confidence limit for", i))
            cisfi[j,2] <- NA
        }
        if(x[n,"deviance"] <= rdevs[j] && th.u) cisfi[j,2] <- x[n, i]
        if(x[n,"deviance"] > rdevs[j])
          cisfi[j,2] <- approx(x[!halves,2], x[!halves,1], xout = rdevs[j])$y
        civals[[i]] <- drop(cisfi)
      }
    }
    civals
}
    
profile2d <- function (fitted, ...) {
    UseMethod("profile2d")
}

"profile2d.evd" <-  function(fitted, prof, which, pts = 20, convergence = FALSE, method = "Nelder-Mead", control = list(maxit = 5000), ...)
{
    if(!inherits(fitted, "evd")) 
        stop("Use only with `evd' objects")
    if(inherits(fitted, "extreme"))
        stop("profiles not implemented for this model")
    if (!inherits(prof, "profile.evd")) 
        stop("`prof' must be a `profile.evd' object")
    if(length(fitted$estimate) < 3)
        stop("Cannot profile two dimensional likelihood")
    if(missing(which) || !is.character(which) || length(which) != 2)
        stop("`which' must be a character vector of length two")
    if(!all(which %in% names(fitted$estimate)))
        stop("`which' contains unrecognized or unestimated parameters")
    if(!all(which %in% names(prof)))
        stop("`which' contains unprofiled parameters")
    if(is.null(fitted$std.err))
       stop("fitted model must contain standard errors")
    prof.list <- as.list(numeric(3))
    names(prof.list) <- c("trace", which)
    limits1 <- range(prof[[which[1]]][,1])
    limits2 <- range(prof[[which[2]]][,1])
    mles <- fitted$estimate[which]                   
    prof <- matrix(NA, nrow = pts^2, ncol = length(fitted$estimate) + 1)
    parvec1 <- seq(limits1[1], limits1[2], length = pts)
    prof.list[[which[1]]] <- parvec1
    parvec2 <- seq(limits2[1], limits2[2], length = pts)
    prof.list[[which[2]]] <- parvec2
    pars <- expand.grid(parvec1, parvec2)
    start <- as.list(fitted$estimate[!names(fitted$estimate) %in% which])
    # if method unspecified supress optim 1d warnings
    if(missing(method) && length(start) == 1) oldopt <- options(warn = -1)
    call.args <- c(list(fitted$data, start, 0, 0), as.list(fitted$fixed),
       list(FALSE, FALSE, method, FALSE, control))
    names(call.args) <- c("x", "start", which[1], which[2],
       names(fitted$fixed), "std.err", "corr", "method",
       "warn.inf", "control")
    dimnames(prof) <- list(NULL, c(which, "deviance", names(start)))
    call.fn <- paste("f", class(fitted)[1], sep="")
    if(inherits(fitted, "gev")) {
        call.args$nsloc <- fitted$nsloc
        call.args$prob <- fitted$prob
    }
    #if(inherits(fitted, "pot")) {
    #    call.args$threshold <- fitted$threshold
    #    call.args$npp <- fitted$npp
    #    call.args$period <- fitted$period
    #    call.args$cmax <- fitted$cmax
    #    call.args$r <- fitted$r
    #    call.args$ulow <- fitted$ulow
    #    call.args$rlow <- fitted$rlow
    #    call.args$mper <- fitted$mper
    #}
    if(inherits(fitted, "bvevd")) {
        call.args$nsloc1 <- fitted$nsloc1
        call.args$nsloc2 <- fitted$nsloc2
        call.args$model <- fitted$model
        call.args$sym <- fitted$sym
        call.args$cloc <- fitted$cmar[1]
        call.args$cscale <- fitted$cmar[2]
        call.args$cshape <- fitted$cmar[3]
        call.args$dsm <- FALSE
    }
    if(inherits(fitted, "bvpot")) {
        call.args$threshold <- fitted$threshold
        call.args$likelihood <- fitted$likelihood
        call.args$model <- fitted$model
        call.args$sym <- fitted$sym
        call.args$cscale <- fitted$cmar[1]
        call.args$cshape <- fitted$cmar[2]
        call.args$dsm <- FALSE          
    }
    for(i in 1:pts^2) {
        call.args[[which[1]]] <- pars[i,1]
        call.args[[which[2]]] <- pars[i,2]
        fit.mod <- do.call(call.fn, call.args)
        if(convergence) print(fit.mod$convergence)
        prof[i,1] <- pars[i,1]
        prof[i,2] <- pars[i,2]
        prof[i,3] <- fit.mod$deviance
        prof[i,-(1:3)] <- fit.mod$estimate
    }
    prof.list[["trace"]] <- prof
    if(missing(method) && length(start) == 1) oldopt <- options(oldopt)
    if(any(prof[,"deviance"] == 2e6))
        warning("non-convergence present in profile2d object")
    structure(prof.list, deviance = fitted$deviance, class = "profile2d.evd")
}

"plot.profile.evd" <-  function(x, which = names(x), main = NULL,
     ask = nb.fig < length(which) && dev.interactive(), ci = 0.95,
     clty = 2, ...) 
{
    if (!inherits(x, "profile.evd")) 
        stop("Use only with `profile.evd' objects")
    if(!is.character(which))
        stop("`which' must be a character vector")
    if(!all(which %in% names(x)))
        stop("`which' contains unprofiled parameters")
    nb.fig <- prod(par("mfcol"))
    if (ask) {
        op <- par(ask = TRUE)
        on.exit(par(op))
    }
    if(is.null(main)) {
        fls <- toupper(substr(which, 1, 1))
        ols <- substr(which, 2, nchar(which))
        cwhich <- paste(fls, ols, sep = "")
        main <- paste("Profile Deviance of", cwhich)
    }
    for(i in which) {
        plot(spline(x[[i]][,1], x[[i]][,2], n = 75), type = "l",
             xlab = i, ylab = "profile deviance",
             main = main[match(i,which)], ...)
        cdist <- attributes(x)$deviance + qchisq(ci, df = 1)
        abline(h = cdist, lty = clty)
    }
    invisible(pcint(prof = x, which = which, ci = ci))
}

"plot.profile2d.evd" <-  function(x, main = NULL, ci = c(0.5,0.8,0.9,0.95,0.975, 0.99, 0.995), col = heat.colors(8), intpts = 75, xaxs = "r", yaxs = "r", ...)
{
    if (!inherits(x, "profile2d.evd")) 
        stop("Use only with `profile2d.evd' objects")
    which <- names(x)[2:3]
    if(is.null(main)) {
        fls <- toupper(substr(which, 1, 1))
        ols <- substr(which, 2, nchar(which))
        cwhich <- paste(fls, ols, sep = "")
        main <- paste("Profile Deviance of", cwhich[1], "and", cwhich[2])
    }
    br.pts <- attributes(x)$deviance + qchisq(c(0,ci), df = 2)
    prof <- x$trace[,"deviance"]
    if(any(prof == 2e6))
        warning("non-convergence present in profile2d object")
    lbak <- TRUE
    if (is.na(match("package:akima", search()))) {
        oldop <- options(warn = -1)
        lbak <- library("akima", char = TRUE, logical = TRUE)
        options(oldop)
        if(lbak) cat("Loaded package akima", "\n")
    }
    if(!lbak) {
        image(x[[which[1]]], x[[which[2]]],
              matrix(prof, nrow = length(x[[which[1]]])),
              col = col, breaks = c(br.pts, 2e6+1),
              main = main, xlab = which[1], ylab = which[2], xaxs = xaxs,
              yaxs = yaxs, ...)
    }
    else {
        lim1 <- range(x[[which[1]]])
        lim2 <- range(x[[which[2]]]) 
        prof.interp <- interp(x$trace[,1], x$trace[,2], prof,
            xo = seq(lim1[1], lim1[2], length = intpts),
            yo = seq(lim2[1], lim2[2], length = intpts))
        image(prof.interp, col = col, breaks = c(br.pts, max(prof)),
              main = main, xlab = which[1], ylab = which[2], xaxs = xaxs,
              yaxs = yaxs, ...)
    }
    invisible(x)
}

"nsloc.transform" <- 
function(x, nsloc)
{
    if(is.vector(nsloc))
        nsloc <- data.frame(trend = nsloc)
    if(!is.data.frame(nsloc))
        stop("`nsloc' must be a vector or data frame")
    if(is.null(dim(x))) ndat <- length(x)
    else ndat <- nrow(x)
    if(nrow(nsloc) != ndat)
        stop("`nsloc' and data are not compatible")
    nsloc
}

"marma" <-
function(n, p = 0, q = 0, psi, theta, init = rep(0, p), n.start = p,
    rand.gen = rfrechet, ...)
{
    if(missing(psi)) psi <- numeric(0)
    if(missing(theta)) theta <- numeric(0)
    if(length(psi) != p || mode(psi) != "numeric" || any(psi < 0))
      stop("`par' must be a non-negative vector of length `p'")
    if(length(theta) != q || mode(theta) != "numeric" || any(theta < 0))
      stop("`theta' must be a non-negative vector of length `q'")
    if(length(init) != p || mode(init) != "numeric" || any(init < 0))
      stop("`init' must be a non-negative vector of length `p'")
    
    marma <- c(init, numeric(n + n.start - p))
    theta <- c(1, theta)
    innov <- rand.gen(n.start + n + q, ...)
    for(i in 1:(n + n.start - p))
      marma[i+p] <- max(c(psi * marma[(i+p-1):i], theta * innov[(i+q):i]))
    if(n.start) marma <- marma[-(1:n.start)]
    marma
}

"mma" <-
function(n, q = 1, theta, rand.gen = rfrechet, ...)
{
    marma(n = n, q = q, theta = theta, rand.gen = rand.gen, ...)
}

"mar" <-
function(n, p = 1, psi, init = rep(0, p), n.start = p, rand.gen =
         rfrechet, ...)
{
    marma(n = n, p = p, psi = psi, init = init, n.start = n.start,
          rand.gen = rand.gen, ...)
}



".First.lib" <-
function(lib, pkg)
{
  library.dynam("evd", package = pkg, lib.loc = lib)
  return(invisible(0))
}

