"grf" <-
  function(n, grid = "irreg",
           nx = round(sqrt(n)), ny = round(sqrt(n)),
           xlims = c(0, 1), ylims = c(0, 1), nsim = 1, 
           cov.model = "matern",
           cov.pars = stop("covariance parameters (sigmasq and phi) needed"),
           kappa = 0.5,  nugget=0, lambda=1, aniso.pars = NULL,
           method = c("cholesky", "svd", "eigen", "circular.embedding"),
           messages.screen = TRUE)
{
  ##
  ## reading and checking input
  ##
  call.fc <- match.call()
  method <- match.arg(method)
  if((method == "circular.embedding") & messages.screen)
    cat("grf: for simulation of fiends with large number of points the consider the packages RandomFields should be considered.\n") 
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  if(!is.null(kappa))
    if(cov.model == "matern" & kappa == 0.5) cov.model <- "exponential"
  rseed <- .Random.seed
  tausq <- nugget
  if (is.vector(cov.pars)) {
    sigmasq <- cov.pars[1]
    phi <- cov.pars[2]
    nst <- 1
  }
  else {
    sigmasq <- cov.pars[, 1]
    phi <- cov.pars[, 2]
    nst <- nrow(cov.pars)
  }
  sill.total <- tausq + sum(sigmasq)
  messa <- grf.aux1(nst, nugget, sigmasq, phi, kappa, cov.model)
  if (messages.screen) {
    cat(messa$nst)
    cat(messa$nugget)
    cat(messa$cov.structures)
    cat(paste("grf: decomposition algorithm used is: ", method, "\n"))
  }
  results <- list()
  ##
  ## defining the locations for the simulated data
  ##
  if (is.matrix(grid) | is.data.frame(grid)) {
    results$coords <- as.matrix(grid)
    if (messages.screen) 
      cat("grf: simulation(s) on a grid provided by the user\n")
  }
  else {
    if (grid == "irreg") {
      results$coords <- cbind(x = runif(n, xlims[1], xlims[2]),
                              y = runif(n, ylims[1], ylims[2]))
      if (messages.screen) 
        cat(paste("grf: simulation(s) on random locations with ", n, " points\n"))
    }
    else {
      results$coords <- as.matrix(expand.grid(x = seq(xlims[1], xlims[2], l = nx),
                                              y = seq(ylims[1], ylims[2], l = ny)))
      if (messages.screen) 
        cat(paste("grf: generating grid ", nx, " * ", ny, 
                  " with ", (nx*ny), " points\n"))
    }
  }
  n <- nrow(results$coords)
  ##
  ## transforming to the isotropic space 
  ##
  if(!is.null(aniso.pars)) {
    if(method == "circular.embedding")
      stop("anisotropic models not implemented for the circular embedding method. \nConsider using the package \"RandomFields")
    if(length(aniso.pars) != 2 | !is.numeric(aniso.pars))
      stop("anisotropy parameters must be provided as a numeric vector with two elements: the rotation angle (in radians) and the anisotropy ratio (a number greater than 1)")
    if(messages.screen)
      cat("grf: transforming to the isotropic space \n")
    results$coords <- coords.aniso(coords = results$coords,
                                   aniso.pars = aniso.pars)
  }
  ##
  ## simulating data at locations defined by the matrix results$coords
  ##
  if (all(phi) == 0) {
    results$data <- matrix(rnorm((n * nsim), mean = 0, sd = sqrt(sill.total)), 
                           nrow = n, ncol = nsim)
  }
  else {
    if (method == "circular.embedding") {
      if (grid == "irreg") 
        stop("Option for \"circular.embedding\" algorithm only allowed for regular grids. You might have to include the argument grid=\"reg\"")
      stepx <- (xlims[2] - xlims[1])/(nx - 1)
      stepy <- (ylims[2] - ylims[1])/(ny - 1)
      if (round(1e+08 * stepx) != round(1e+08 *stepy)) 
        stop("grf: distance between grid points must be the same in X and Y directions")
      temp <- list(n = n, nst = nst, sigmasq = sigmasq, 
                   xlims = xlims, ylims = ylims, stepx = stepx, 
                   cov.model = cov.model, phi = phi, kappa = kappa)
      if(messages.screen)
        cat("\ngrf: WARNING:\nmessages of the type mtot=XXXXX will appear on your screen. \nIf there are many (3 or more, say) or they run indefinitely, you should stop the simulation and try again with a different grid (e.g. try to add 1 point in each direction)\n")
      grf.aux3 <- function (nsim, temp) {
        realiz <- rep(0, temp$n)
        for (i in 1:temp$nst) {
          realiz <- realiz + sqrt(temp$sigmasq[i]) *
            grf.aux2(xlim = temp$xlims, 
                     ylim = temp$ylims, step = temp$stepx,
                     cov.model = temp$cov.model,
                     phi = temp$phi[i], kappa = temp$kappa)
          NULL
        }
        return(realiz)
      }      
      results$data <- apply(as.matrix(1:nsim), 1, grf.aux3, temp = temp)
      if (nugget != 0) {
        results$data <- results$data + matrix(rnorm((n * nsim), sd = sqrt(nugget)), 
                                              ncol = nsim)
      }
    }
    else{
      results$data <- matrix(rnorm((n * nsim)), nrow = n, ncol = nsim)
      cov.decomp <- t(varcov.spatial(coords = results$coords, 
                                   cov.model = cov.model, kappa = kappa,
                                   nugget = nugget, cov.pars = cov.pars, 
                                   only.decomposition = TRUE,
                                   func.inv = method)$sqrt.varcov)
      results$data <- cov.decomp %*% results$data
    }
    if (nsim == 1) 
      results$data <- as.vector(results$data)
  }
  ##
  ## transforming data (Box - Cox)
  ##
  if (lambda != 1){
    if (lambda != 0)
      results$data <- (results$data * lambda + 1)^(1/lambda)
    else
      results$data <- exp(results$data)
    messa$transformation <- paste("grf: Data transformed (Box-Cox), for lambda =", lambda)
    if (messages.screen) 
      cat(messa$transformation); cat("\n")
  }
  ##
  ## back-transformation to the anisotropic space 
  ##
  if(!is.null(aniso.pars)) {
    if(messages.screen)
      cat("grf: back-transforming to the anisotropic space \n")
    results$coords <- coords.aniso(coords = results$coords,
                                   aniso.pars = aniso.pars, reverse=TRUE)
  }
  else{aniso.pars <- "no anisotropy parameters provided/used"}
  ##
  ## preparing output
  ##
  if (messages.screen) 
    cat(paste("grf: End of simulation procedure. Number of realizations:",
              nsim, "\n"))
  results  <- c(results, list(cov.model = cov.model, 
                              nugget = nugget, cov.pars = cov.pars,
                              kappa = kappa, lambda = lambda,
                              aniso.pars = aniso.pars, method = method,
                              .Random.seed = rseed, messages = messa,
                              call = call.fc))
  class(results) <- c("grf", "geodata")
  return(results)
}

"grf.aux1" <-
  function (nst, nugget, sigmasq, phi, kappa, cov.model) 
{
  cov.nst <- paste("grf: process with ", nst, " covariance structure(s)\n")
  cov.nugget <- paste("grf: nugget effect is: tausq=", nugget,"\n")
  cov.message <- NULL
  for (i in 1:nst) {
    if (phi[i] == 0) 
      cov.message[i] <- paste("grf: covariance model", i, "is a pure nugget effect\n")
    else {
      if (cov.model == "matern" | cov.model == "powered.exponential" | 
          cov.model == "cauchy" | cov.model == "gneiting-matern") 
        cov.message[i] <- paste("grf: covariance model ", 
                                i, " is: ", cov.model, "(sigmasq=", sigmasq[i], 
                                ", phi=", phi[i], ", kappa = ", kappa, ")\n", sep = "")
      else cov.message[i] <- paste("grf: covariance model ", 
                                   i, " is: ", cov.model, "(sigmasq=", sigmasq[i], 
                                   ", phi=", phi[i], ")\n", sep = "")
    }
  }
  return(list(nst = cov.nst, nugget = cov.nugget, cov.structures = cov.message))
}
"grf.aux2" <-
  function (xlim, ylim, step, cov.model, phi, kappa = 0.5) 
{
  if(!is.null(kappa))
    if (cov.model == "matern" & kappa == 0.5) {
      cov.model <- "exponential"
    }
  cs <- switch(cov.model,
               spherical = c(1,1),
               gneiting.matern = c(2, kappa),
               powered.exponential = c(3,kappa),
               exponential = c(3,1),
               gaussian = c(3,2),
               matern = c(4, kappa),
               gneiting = c(5,1),
               cauchy = c(6,kappa),
               wave = c(7,1))
  covfct <- cs[1]
  shape <- cs[2]
  parameter <- c(phi, shape, 1)
  nx <- c(diff(xlim)/step + 1, diff(ylim)/step + 1)
  storage.mode(nx) <- "integer"
  ln <- 2
  storage.mode(ln) <- "integer"
  covnr <- covfct
  storage.mode(covnr) <- "integer"
  simustep <- step
  storage.mode(simustep) <- "double"
  param <- parameter
  storage.mode(param) <- "double"
  lparam <- length(parameter)
  storage.mode(lparam) <- "integer"
  res <- double(nx[1] * nx[2])
  mm <- integer(ln)
  x <- .C("woodandchan", covnr, nx, ln, simustep, param, lparam, 
          res = res, m = mm)$res
  cat("\n")
  return(x)
}


"likfit.nospatial" <-
  function(temp.list, ...)
{
  results <- list()
  z <- temp.list$z
  n <- temp.list$n
  beta.size <- temp.list$beta.size
  xmat <- temp.list$xmat
  txmat <- temp.list$txmat
  ixx <- solve(crossprod(xmat))
  if(temp.list$fix.lambda == FALSE){
    if (temp.list$minimisation.function == "nlm"){
      assign(".temp.lower.lambda",-2, pos=1)
      assign(".temp.upper.lambda", 2, pos=1)
      results <- nlm(proflik.lambda, 1, ...)
      if(exists(".temp.lambda")){
        results$lambda <- .temp.lambda
        remove(".temp.lambda", pos=1, inherits = TRUE)
      }
      else{
        results$lambda <- results$estimate
      }
      rm(.temp.lower.lambda, .temp.upper.lambda, inherits = TRUE, pos=1)
    }
    if (temp.list$minimisation.function == "nlmP"){
      results <- nlmP(proflik.lambda, 1, lower=-2, upper=2,...)  
      results$lambda <- results$estimate
    }
    if (temp.list$minimisation.function == "optim"){
      results <- optim(1, proflik.lambda, method="L-BFGS-B", lower=-2, upper=2,...)
      results$minimum <- results$value
      results$lambda <- results$par
    }
    if(results$lambda == 1) {
      temp.list$log.jacobian <- 0
    }
    else {
      if(any(z <= 0))
        stop("Transformation option not allowed when there are zeros or negative data")
      if(any(z^(results$lambda - 1) <= 0))
        temp.list$log.jacobian <- log(prod(z^(results$lambda - 1)))
      else temp.list$log.jacobian <- sum(log(z^(results$lambda - 1)))
      if(results$lambda == 0)
        z <- log(z)
      else z <- ((z^results$lambda) - 1)/results$lambda
    }
  }
  else{
    results$lambda <- temp.list$lambda
    results$code <- 1
    if (temp.list$minimisation.function == "optim") results$convergence <- 0
  }
  ssres <- (z %*% (diag(n) - xmat %*%
                   solve(crossprod(xmat)) %*% txmat) %*% z)
  if(temp.list$method == "ML"){
    results$tausqhat <- ssres/n
    if(temp.list$fix.lambda)
      results$minimum <- as.vector(((n/2) * log(2 * pi) +
                          (n/2) * log(results$tausqhat) +
                          (n/2)  -
                          temp.list$log.jacobian))
  }
  if(temp.list$method == "RML") {
    results$tausqhat  <- (ssres/(n-beta.size))
    if(temp.list$fix.lambda){
      results$minimum <- as.vector((((n - beta.size)/2) * log(2 * pi) +
                          ((n - beta.size)/2) * log(results$tausqhat) +
                          (n/2) -
                          temp.list$log.jacobian
                          ))
    }
  }
  if (temp.list$minimisation.function == "optim") results$value <- results$minimum    
  return(results)
}

"loglik.spatial" <-
function(pars)
{
  tausq <- pars[1]
  sigmasq <- pars[2]
  sill.total <- tausq + sigmasq
  phi <- pars[3]
  lambda <- pars[4]
  z <- .temp.list$z
  n <- .temp.list$n
  if(.temp.list$fix.lambda == FALSE) {
    if(lambda == 1) {
      .temp.list$log.jacobian <- 0
    }
    else {
      if(any(z < 0))
        stop("Transformation option not allowed when there are zeros or negative data"
             )
      if(any(z^(lambda - 1) <= 0))
        .temp.list$log.jacobian <- log(prod(z^(lambda -
                                               1)))
      else .temp.list$log.jacobian <- sum(log(z^(lambda - 1)))
      if(lambda == 0)
        z <- log(z)
      else z <- ((z^lambda) - 1)/lambda
    }
  }
  beta.size <- .temp.list$beta.size
  kappa <- .temp.list$kappa
  covinf <- varcov.spatial(dists.lowertri = .temp.list$
                           dists.lowertri, cov.model = .temp.list$cov.model,
                           kappa = kappa, nugget = tausq,
                           cov.pars = c(sigmasq, phi), scaled = FALSE,
                           inv = TRUE, det = TRUE,
                           only.inv.lower.diag = TRUE)
  xix <- as.double(rep(0, beta.size*beta.size))
  xix <- .C("bilinearform_XAY",
            as.double(covinf$lower.inverse),
            as.double(covinf$diag.inverse),
            as.double(as.vector(.temp.list$xmat)),
            as.double(as.vector(.temp.list$xmat)),
            as.integer(beta.size),
            as.integer(beta.size),
            as.integer(n),
            res = xix)$res
  attr(xix, "dim") <- c(beta.size, beta.size)
  if(length(as.vector(xix)) == 1) {
    ixix <- 1/xix
    choldet <- 0.5 * log(xix)
  }
  else {
    chol.xix <- chol(xix)
    ixix <- chol2inv(chol.xix)
    choldet <- sum(log(diag(chol.xix)))
  }
  xiy <- as.double(rep(0, beta.size))
  xiy <- .C("bilinearform_XAY",
            as.double(covinf$lower.inverse),
            as.double(covinf$diag.inverse),
            as.double(as.vector(.temp.list$xmat)),
            as.double(as.vector(z)),
            as.integer(beta.size),
            as.integer(1),
            as.integer(n),
            res = xiy)$res
  beta.hat <- as.vector(ixix %*% xiy)
  yiy <- as.double(0.0)
  yiy <- .C("bilinearform_XAY",
            as.double(covinf$lower.inverse),
            as.double(covinf$diag.inverse),
            as.double(as.vector(z)),
            as.double(as.vector(z)),
            as.integer(1),
            as.integer(1),
            as.integer(n),
            res = yiy)$res
  ssresmat <- as.vector(yiy - 2*crossprod(beta.hat,xiy) +  beta.hat %*% xix %*% beta.hat)
  if(.temp.list$method == "ML") {
    loglik <- ( - (n/2) * log(2 * pi) -
               covinf$log.det.to.half -
               0.5 * ssresmat + 
               .temp.list$log.jacobian)
  }
  if(.temp.list$method == "RML") {
    xx.eigen <- eigen(crossprod(.temp.list$xmat), symmetric = TRUE, only.values = TRUE)
    loglik <- ( - ((n - beta.size)/2) * log(2 * pi) +
               0.5 * sum(log(xx.eigen$values)) -
               covinf$log.det.to.half -
               (0.5) * ssresmat -
               choldet +
               .temp.list$log.jacobian)
  }
  return(as.vector(loglik))
}

"matern" <-
  function (u, phi, kappa) 
{
  if(is.vector(u)) names(u) <- NULL
  if(is.matrix(u)) dimnames(u) <- list(NULL, NULL)
  uvec <- u/phi
  ucov <- ifelse(uvec > 0, ((((2^(kappa-1))*gamma(kappa))^(-1))*(uvec^kappa)*besselK(x=uvec, nu=kappa)), 1)    
  ## The following needs more checking:
  ##        min.non.inf <- min(ucov[ucov != Inf])
  ##        dist.min.non.inf <- min(u[ucov <= 1.01 * min.non.inf])
  ##        ucov[u <= dist.min.non.inf] <- 0
  ##        print(c(phi, dist.min.non.inf, min.non.inf))        
  ##
  ucov[u > 600*phi] <- 0 
  return(ucov)
}


"nlmP" <-
  function(objfunc, params, lower = rep( -Inf, length(params)),
           upper = rep(+Inf, length(params)), ... )
{
  ## minimizer, using nlm with transformation of variables
  ##
  ## objfunc is a function to be optimised
  ## params is a starting value for the parameters
  Nparams <- length(params)
  if(length(lower) != Nparams)
    stop(" lower boundry different length than params")
  if(length(upper) != Nparams)
    stop(" upper boundry different length than params")
  checklimits <- upper - lower
  if(any(checklimits <= 0))
    stop(" bad boundries")
  if(any(params < lower))
    stop(" starting params too low")
  if(any(params > upper))
    stop(" starting params too high")
  
  bothlimQQ <- (lower != (-Inf)) & (upper != +Inf)
  loweronlyQQ <- (lower != (-Inf)) & (upper == +Inf)
  upperonlyQQ <- (lower == (-Inf)) & (upper != +Inf)
  ubothQQ <- upper[bothlimQQ]
  lbothQQ <- lower[bothlimQQ]
  dbothQQ <- ubothQQ - lbothQQ
  loneQQ <- lower[loweronlyQQ]
  uoneQQ <- upper[upperonlyQQ]
  
  .bounds.list <- list(bothlimQQ = bothlimQQ, 
                       loweronlyQQ = loweronlyQQ,
                       upperonlyQQ = upperonlyQQ,
                       ubothQQ = ubothQQ,
                       lbothQQ = lbothQQ,
                       dbothQQ = dbothQQ,
                       loneQQ = loneQQ,
                       uoneQQ = uoneQQ)
  
  assign(".objfuncQQ", objfunc, pos=1)
  assign(".bounds.list", .bounds.list, pos=1)
  
  ## reduce the parameter space by a scale to keep parameters
  ## away from the boundries
  
  normaltomad <- function(normalparamsX)
    {
      madparamsX <- normalparamsX
      if(any(.bounds.list$bothlimQQ)) {
        noughtone <- (normalparamsX[.bounds.list$bothlimQQ] -
                      .bounds.list$lbothQQ)/.bounds.list$dbothQQ
        madparamsX[.bounds.list$bothlimQQ] <- log(noughtone/(1 - noughtone))
      }
      
      if(any(.bounds.list$loweronlyQQ))
        madparamsX[.bounds.list$loweronlyQQ] <-
          log(normalparamsX[.bounds.list$loweronlyQQ] - .bounds.list$loneQQ)
      
      if(any(.bounds.list$upperonlyQQ))
        madparamsX[.bounds.list$upperonlyQQ] <-
          log(.bounds.list$uoneQQ - normalparamsX[.bounds.list$upperonlyQQ])
      
      return(madparamsX)
    }
  
  madtonormalQQ <<- function(madparamsX)
    {
      normalparamsX <- madparamsX
      
      if(any(.bounds.list$bothlimQQ)) {
###        madparamsX[((.bounds.list$bothlimQQ) & (madparamsX > 300))] <- 300
        emad <- exp(madparamsX[.bounds.list$bothlimQQ])
        normalparamsX[.bounds.list$bothlimQQ] <-
          .bounds.list$dbothQQ * (emad/(1 + emad)) + .bounds.list$lbothQQ
      }
      
      if(any(.bounds.list$loweronlyQQ)){
        normalparamsX[.bounds.list$loweronlyQQ] <-
          exp(madparamsX[.bounds.list$loweronlyQQ]) + .bounds.list$loneQQ
      }
      
      if(any(.bounds.list$upperonlyQQ))
        normalparamsX[.bounds.list$upperonlyQQ] <-
          - exp(madparamsX[.bounds.list$upperonlyQQ]) + .bounds.list$uoneQQ
      
      if(exists(".ind.prof.phi"))
        if(is.nan(normalparamsX[.ind.prof.phi]))
          normalparamsX[.ind.prof.phi] <- 0
      
      return(normalparamsX)
    }
  
  newobjfunc <- function(madparams) {
    normalparams <-  madtonormalQQ(madparams)
    
    .objfuncQQ(normalparams)
    
  }
  
  startmadparams <- normaltomad(params)
  result <- nlm(newobjfunc, startmadparams, ...)
  result$madestimate <- result$estimate
  result$estimate <- madtonormalQQ(result$madestimate)
  remove(".bounds.list", pos=1, inherits=T)
  remove(".objfuncQQ", pos=1, inherits=T)
  remove("madtonormalQQ", pos=1, inherits=T)
  
###  return(result, madtonormalQQ(normaltomad(params)),params)
  return(result)
}

"points.geodata" <-
  function (geodata, coords = geodata$coords, data = geodata$data, 
            data.col = 1, borders = NULL,
            pt.sizes = c("data.proportional",
              "rank.proportional", "quintiles",
              "quartiles", "deciles", "equal"),
            cex.min, cex.max, pch.seq, col.seq, add.to.plot = FALSE,
            round.quantiles = FALSE, graph.pars = FALSE, ...) 
{
  pt.sizes <- match.arg(pt.sizes)
  if(!is.vector(data))
       data <- (as.data.frame(data))[,data.col]
  if(nrow(coords) != length(data))
    stop("coords and data have incompatible sizes")
  if (add.to.plot == FALSE) {
    if(is.null(borders))
      coords.lims <- apply(coords, 2, range)
    else
      coords.lims <- apply(rbind(coords, borders), 2, range)
    coords.diff <- diff(coords.lims)
    if (coords.diff[1] != coords.diff[2]) {
      coords.diff.diff <- abs(diff(as.vector(coords.diff)))
      ind.min <- which(coords.diff == min(coords.diff))
      coords.lims[, ind.min] <- coords.lims[, ind.min] + 
        c(-coords.diff.diff, coords.diff.diff)/2
    }
    par(pty = "s")
    plot(apply(coords, 2, range), type = "n", xlim = coords.lims[, 
                                                1], ylim = coords.lims[, 2], ...)
    if(!is.null(borders))
      lines(borders)
  }
  if (missing(cex.min)) 
    cex.min <- 0.5
  if (missing(cex.max)) 
    cex.max <- 1.5
  graph.list <- list()
  if (pt.sizes == "quintiles" | pt.sizes == "quartiles" | pt.sizes == 
      "deciles") {
    if (pt.sizes == "quintiles") {
      n.quant <- 5
      if (missing(col.seq)) 
        col.seq <- c("blue", "green", "yellow", "orange3", "red2") 
    }
    if (pt.sizes == "quartiles") {
      n.quant <- 4
      if (missing(col.seq)) 
        col.seq <- c("blue", "green", "yellow", "red") 
    }
    if (pt.sizes == "deciles") {
      n.quant <- 10
      if (missing(col.seq)) 
        col.seq <- rainbow(13)[10:1]
    }
    if (missing(pch.seq)) 
      pch.seq <- rep(21, n.quant)
    cex.pt <- seq(cex.min, cex.max, l = n.quant)
    data.quantile <- quantile(data, probs = seq(0, 1, by = (1/n.quant)))
    if (round.quantiles == TRUE) {
      data.quantile[1] <- floor(data.quantile[1])
      data.quantile[n.quant + 1] <- ceiling(data.quantile[n.quant + 1])
      data.quantile <- round(data.quantile)
    }
    graph.list$quantiles <- data.quantile
    graph.list$cex <- cex.pt
    graph.list$col <- col.seq
    graph.list$pch <- pch.seq
    graph.list$data.group <- cut(data, breaks=data.quantile, include.l=T)
    if (add.to.plot) 
      points(coords, pch = 21, cex = cex.pt[as.numeric(graph.list$data.group)], bg = col.seq[as.numeric(graph.list$data.group)], ...)
    else
      points(coords, pch = 21, cex = cex.pt[as.numeric(graph.list$data.group)], bg = col.seq[as.numeric(graph.list$data.group)])
  }
  else {
    if (missing(pch.seq)) 
      pch.seq <- 21
    if (missing(col.seq)) 
      col.seq <- 0
    n <- length(data)
    coords.order <- coords[order(data), ]
    data.order <- data[order(data)]
    if (pt.sizes == "rank.proportional") {
      data.quantile <- range(data.order)
      size <- seq(cex.min, cex.max, l = n)
      graph.list$cex <- range(size)
      graph.list$pch <- unique(range(pch.seq))
      graph.list$col <- col.seq
      if (length(col.seq) == 1) 
        col.seq <- rep(col.seq, n)
      for (i in 1:n) {
        if (add.to.plot) 
          points(coords.order[i, , drop = FALSE], cex = size[i], 
                 pch = pch.seq, bg = col.seq[i], ...)
        else points(coords.order[i, , drop = FALSE], 
                    cex = size[i], pch = pch.seq, bg = col.seq[i])
      }
    }
    if (pt.sizes == "data.proportional") {
      r.y <- range(data.order)
      size <- cex.min + ((data.order - r.y[1]) * (cex.max - 
                                                  cex.min))/(r.y[2] - r.y[1])
      graph.list$cex <- c(cex.min, cex.max)
      graph.list$pch <- unique(range(pch.seq))
      graph.list$col <- col.seq
      if (length(col.seq) == 1) 
        col.seq <- rep(col.seq, n)
      for (i in 1:n) {
        if (add.to.plot) 
          points(coords.order[i, , drop = FALSE], cex = size[i], 
                 pch = pch.seq, bg = col.seq[i], ...)
        else points(coords.order[i, , drop = FALSE], 
                    cex = size[i], pch = pch.seq, bg = col.seq[i])
      }
    }
    if (pt.sizes == "equal") {
      if (add.to.plot) 
        points(coords, pch = pch.seq, bg = col.seq, cex = cex.max, 
               ...)
      else points(coords, pch = pch.seq, bg = col.seq, 
                  cex = cex.max)
    }
  }
  if (graph.pars == TRUE) 
    return(graph.list)
  else return(invisible())
}

"lines.grf" <-
  function (obj, max.dist = max(dist(obj$coords)), length = 100, 
            lwd = 2, ...) 
{
  if(is.R()) require(mva)
  if (obj$cov.model == "matern" | obj$cov.model == "powered.exponential" | 
      obj$cov.model == "cauchy" | obj$cov.model == "gneiting-matern") 
    kappa <- obj$kappa
  else kappa <- NULL
  distance <- seq(0, max.dist, length = length)
  if (is.vector(obj$cov.pars)) 
    sill.total <- obj$nugget + obj$cov.pars[1]
  else sill.total <- obj$nugget + sum(obj$cov.pars[, 1])
  gamma <- sill.total - cov.spatial(distance, cov.model = obj$cov.model, 
                                  kappa = kappa, cov.pars = obj$cov.pars)
  lines(distance, gamma, lwd = lwd, ...)
  return(invisible())
}

"cov.spatial" <-
  function(obj, cov.model = c("matern", "exponential", "gaussian", "spherical",
                  "circular", "cubic", "wave", "power", "powered.exponential",
                  "cauchy", "gneiting", "gneiting.matern", "pure.nugget"),
           cov.pars = stop("no cov.pars argument provided"), kappa = 0.5)
{
  ##
  ## checking/reading input
  ##
  cov.model <- match.arg(cov.model)
  if(cov.model == "matern" | cov.model == "powered.exponential" | 
     cov.model == "cauchy" | cov.model == "gneiting.matern"){
    if(is.null(kappa))
      stop("for matern, powered.exponential, cauchy and gneiting.matern covariance functions the parameter kappa must be provided")
    if(cov.model == "gneiting.matern" & length(kappa) != 2)
      stop("gneiting.matern correlation function model requires a vector with 2 parameters in the argument kappa")
    if((cov.model == "matern" | cov.model == "powered.exponential" | 
        cov.model == "cauchy") & length(kappa) != 1)
      stop("for this choice of  correlation function model kappa should be a scalar parameter")
    if(cov.model == "matern" & kappa == 0.5)
      cov.model == "exponential"
  }
  if(is.vector(cov.pars))
    sigmasq <- cov.pars[1]
  else sigmasq <- cov.pars[, 1]
  if(is.vector(cov.pars))
    phi <- cov.pars[2]
  else phi <- cov.pars[, 2]
  if(is.vector(cov.pars))
    ns <- 1
  else ns <- nrow(cov.pars)
  covs <- array(0, dim = dim(obj))
  ##
  ## computing correlations/covariances
  ##
  for(i in 1:ns) {
    if(phi[i] < 1e-12)
      cov.model <- "pure.nugget"
    cov.values <- switch(cov.model,
                  pure.nugget = rep(0, length(obj)),
                  wave = (1/obj) * (phi[i] * sin(obj/phi[i])),
                  exponential = exp( - (obj/phi[i])),
                  matern = matern(u = obj, phi = phi[i], kappa = kappa),
                  gaussian = exp( - ((obj/phi[i])^2)),
                  spherical = ifelse(obj < phi[i], (1 - 1.5 * (obj/phi[i]) +
                    0.5 * (obj/phi[i])^3), 0),
                  circular = {
                    obj.sc <- obj/phi[i];
                    obj.sc[obj.sc > 1] <- 1;
                    ifelse(obj < phi[i], (1 - (2 * ((obj.sc) *
                                                    sqrt(1 - ((obj.sc)^2)) +
                                                    asin(obj.sc)))/pi), 0)
                  },
                  cubic = {
                    obj.sc <- obj/phi[i];
                    ifelse(obj < phi[i], (1 - (7 * (obj.sc^2) -
                                               8.75 * (obj.sc^3) +
                                               3.5 * (obj.sc^5) -
                                               0.75 * (obj.sc^7))), 0)
                  },
                  power = (obj)^phi,
                  powered.exponential = {
                    if(kappa > 2 | kappa <= 0)
                      stop("for power exponential correlation model the parameter kappa must be in the intervel (0,2]"
                           );
                    exp( - ((obj/phi[i])^kappa))
                  },
                  cauchy = (1 + (obj/phi[i])^2)^(-1 * kappa),
                  gneiting = {
                    obj.sc <- obj/phi[i];
                    t2 <- (1 - obj.sc);
                    t2 <- ifelse(t2 > 0, (t2^8), 0);
                    (1 + 8 * obj.sc + 25 * (obj.sc^2) + 32 * (obj.sc^
                                                              3)) * t2
                  },
                  gneiting.matern = { 
                    obj.sc <- obj/(phi[i] * kappa[2]);
                    t2 <- (1 - obj.sc);
                    t2 <- ifelse(t2 > 0, (t2^8), 0);
                    cov.values <- (1 + 8 * obj.sc + 25 * (obj.sc^2) + 32 * (obj.sc^3)) * t2;
                    cov.values * matern(u = obj, phi = phi[i], kappa = kappa[1])
                  },
                  stop("wrong or no specification of cov.model")
                  )
    cov.values <- sigmasq[i] * cov.values
    covs <- covs + cov.values
  }
  covs[obj < 1e-15] <- sum(sigmasq)
  return(covs)
}

"cor.number" <- 
  function(cov.model= c("exponential", "matern", "gaussian",
             "spherical", "circular", "cubic", "wave", "power",
             "powered.exponential", "cauchy", "gneiting",
             "gneiting.matern", "pure.nugget"))
{
###	WARNING: codes above must be the same as in the C code
###              "cor_diag"
  
  cov.model <- match.arg(cov.model)
  cornumber <- switch(cov.model,
                      pure.nugget = as.integer(1),
                      exponential = as.integer(2),
                      spherical = as.integer(3),
                      gaussian = as.integer(4),
                      wave = as.integer(5),
                      cubic = as.integer(6),
                      power = as.integer(7),
                      powered.exponential = as.integer(8),
                      cauchy = as.integer(9),
                      gneiting = as.integer(10),
                      circular = as.integer(11),
                      matern = as.integer(12),
                      gneiting.matern = as.integer(13),
                      stop("wrong or no specification of cov.model")
                      )
  return(cornumber)
}

"read.geodata" <-
  function(file, header = FALSE, coords.col= 1:2, data.col = 3,
           data.names = NULL, covar.col = NULL, covar.names = "header", ...)
{
  call.fc <- match.call()
  obj <- read.table(file = file, header = header, ...)
  if(covar.names == "header"){
    if(!is.null(covar.col)){
      col.names <- names(obj)
      covar.names <- col.names[covar.col]
    }
    else covar.names <- NULL
  }
  res <- as.geodata(obj = obj, coords.col = coords.col, data.col = data.col,
                    covar.col = covar.col, covar.names = covar.names)
  res$call <- call.fc
  return(res)
}

"as.geodata" <-
  function(obj, coords.col = 1:2, data.col = 3, data.names = NULL, 
           covar.col = NULL, covar.names = "obj.names")
{
  if(!is.matrix(obj) & !is.data.frame(obj))
    stop("object must be a matrix or data.frame")
  if(!is.null(data.names) & length(data.col) < 2)
    stop("data.names allowed only if there is more than 1 column of data")
  res <- list()
  res$coords <- as.matrix(obj[,coords.col])
  res$data <- as.matrix(obj[,data.col])
  if(length(data.col) == 1) res$data <- as.vector(res$data)
  else{
    res$data <- as.data.frame(res$data)
    if(!is.null(data.names)) names(res$data) <- data.names
  }
  if(!is.null(covar.col)){
    res[[3]] <- as.data.frame(as.matrix(obj[,covar.col]))
    if(covar.names == "obj.names"){
      if(is.matrix(obj))      
        col.names <- dimnames(obj)[2]
      if(is.data.frame(obj))      
        col.names <- names(obj)
    }
    if(length(covar.col) == 1){
      if(covar.names == "obj.names")
        names(res)[3] <- col.names[covar.col]
      else
        names(res)[3] <- covar.names
    }
    else{
      names(res)[3] <- "covariates"
      if(covar.names == "obj.names")
        names(res[[3]]) <- col.names[covar.col]
      else
        names(res[[3]]) <- covar.names
    }
  }
  require(mva)
  if(min(dist(res$coords)) < 1e-12)
    cat("WARNING: there are data at coincident locations, several geoR functions will not work\n") 
  class(res) <- "geodata"
  return(res)
}


"image.grf" <-
  function (obj, sim.number = 1, ...) 
{
  x <- as.numeric(levels(as.factor(obj$coords[, 1])))
  nx <- length(x)
  y <- as.numeric(levels(as.factor(obj$coords[, 2])))
  ny <- length(y)
  obj$data <- as.matrix(obj$data)
  n <- nrow(obj$data)
  if (nx * ny != n) 
    stop("Probably irregular grid")
  m <- matrix(obj$data[, sim.number], ncol = ny)
  coords.lims <- set.coords.lims(coords=obj$coords)
  pty.prev <- par()$pty
  par(pty = "s")
  image(x, y, m, xlim= coords.lims[,1], ylim=coords.lims[,2],...)
  par(pty=pty.prev)
  return(invisible())
}

"lines.variomodel" <-
  function (obj, max.dist, scaled = FALSE,...)
{
  my.l <- list()
  if(missing(max.dist)){
    my.l$max.dist <- obj$max.dist
    if (is.null(my.l$max.dist)) 
      stop("argument max.dist needed for this object")
  }
  if (obj$cov.model == "matern" | obj$cov.model == "powered.exponential" | 
      obj$cov.model == "cauchy" | obj$cov.model == "gneiting-matern") 
    my.l$kappa <- obj$kappa
  else kappa <- NULL
  if (is.vector(obj$cov.pars)) 
    my.l$sill.total <- obj$nugget + obj$cov.pars[1]
  else my.l$sill.total <- obj$nugget + sum(obj$cov.pars[, 1])
  my.l$cov.pars <- obj$cov.pars
  my.l$cov.model <- obj$cov.model
  if (scaled){
    if(is.vector(obj$cov.model))
      my.l$cov.pars[1] <-  my.l$cov.pars[1]/sill.total
    else my.l$cov.pars[,1] <-  my.l$cov.cov.pars[,1]/sill.total
    my.l$sill.total <- 1
  }
  gamma.f <- function(x, my.l)
    {
      return(my.l$sill.total -
             cov.spatial(x, cov.model = my.l$cov.model, kappa = my.l$kappa,
                         cov.pars = my.l$cov.pars))
    }
  curve(gamma.f(x,my.l=my.l), from = 0, to = my.l$max.dist, add=TRUE, ...)
  return(invisible())
}

"persp.grf" <- 
function(obj, sim.number = 1, ...)
{
	x <- as.numeric(levels(as.factor(obj$coords[, 1])))
	nx <- length(x)
	y <- as.numeric(levels(as.factor(obj$coords[, 2])))
	ny <- length(y)
	obj$data <- as.matrix(obj$data)
	n <- nrow(obj$data)
	if(nx * ny != n)
		stop("Probably irregular grid")
	m <- matrix(obj$data[, sim.number], ncol = ny)
	persp(x, y, m, ...)
	return(invisible())
}

"coords.aniso" <- 
  function(coords, aniso.pars, reverse=FALSE)
{
  coords <- as.matrix(coords)
  n <- nrow(coords)
  if(length(aniso.pars) != 2)
    stop("argument aniso.pars must be a vector with 2 elementsm the anisotropy angle and anisotropy ratio, respectively")
  psiA <- aniso.pars[1]
  psiR <- aniso.pars[2]
  if(psiR < 1){
    psiR <- round(psiR, dig=8)
    if(psiR < 1)
      stop("anisotropy ratio must be greater than 1")
  }
  rm <- matrix(c(cos(psiA), -sin(psiA),
                 sin(psiA), cos(psiA)),
               ncol = 2)
  tm <- diag(c(1, 1/psiR))
  if(reverse)
    coords.mod <- coords %*% solve(rm %*% tm)
  else
    coords.mod <- coords %*% rm %*% tm
  return(coords.mod)
}


"plot.grf" <-
  function (obj, model.line = TRUE, plot.grid = FALSE, ylim="default", ...) 
{
  nsim <- ncol(obj$data)
  if (plot.grid) 
    points.geodata(obj, pt.siz="equal", xlab = "Coord X", ylab = "Coord Y")
  if (is.vector(obj$cov.pars)) 
    sill.total <- obj$nugget + obj$cov.pars[1]
  else sill.total <- obj$nugget + sum(obj$cov.pars[, 1])
  if (obj$lambda != 1){
    if (obj$lambda == 0) data <- log(obj$data)
    else data <- ((obj$data^obj$lambda)-1)/obj$lambda
  }
  else
    data <- obj$data          
  sim.bin <- variog(obj, data=data)
  plot(sim.bin, ...)
  if (model.line){
    var.model <- list(nugget = obj$nugget, cov.pars = obj$cov.pars, 
                      kappa = obj$kappa, max.dist = max(sim.bin$u),
                      cov.model = obj$cov.model)
    lines.variomodel(var.model, lwd = 3)
  }
  return(invisible())
}


"trend.spatial" <-
  function(trend, coords=NULL)
{
  if(inherits(trend, "formula")){
    trend.mat <- model.matrix(trend)
  }
  else{
    if(trend == "cte")
      trend.mat <- as.matrix(rep(1, nrow(coords)))
    else
      if(trend == "1st")
        trend.mat <- cbind(1, coords)
      else
        if(trend == "2nd")
          trend.mat <- cbind(1, coords, coords[, 1]^2, coords[
                                                              , 2]^2, coords[, 1] * coords[, 2])
	else
          stop("external trend must be provided for data locations to be estimated using the argments `trend.d` and `trend.l`. Both (trend.d and trend.l) must be the same `cte`, `1st`, `2nd` or given by a formula of the type ~X where X is a matrix or vector of covariates."
               )
  }
  trend.mat <- as.matrix(trend.mat)
  dimnames(trend.mat) <- list(NULL, NULL)
  return(trend.mat)
}

#"dist0.krige" <-
#function (x0, coords) 
#{
#  if (length(x0) != 2) 
#    stop(paste("length of x0 is", length(x0), "(it must be 2)"))
#  coords[, 1] <- coords[, 1] - x0[1]
#  coords[, 2] <- coords[, 2] - x0[2]
#  return(sqrt(coords[, 1]^2 + coords[, 2]^2))
#}


"polygrid" <- 
  function(xgrid, ygrid, poly, vec.inout = F)
{
  if(is.R())
  	require(splancs)
  if(exists("inout")){
    xygrid <- expand.grid(x = xgrid, y = ygrid)
    ind <- as.vector(inout(pts=xygrid, poly=poly))
    xypoly <- xygrid[ind == T,  ]
    if(vec.inout == F)
      return(xypoly)
    else return(list(xypoly = xypoly, vec.inout = ind))
  }
  else{
    cat("ERROR: cannot run the function\n")
    cat("package \"splancs\" should be installed/loaded")
    return(invisible())
  }
}

#"variog.env" <-
#  function (obj.variog, coords, model.pars, nsim = 99, messages.screen = TRUE)  
#{
#  cat("This function has been made obsolete\n")
#  cat("There are now two functions for variogram envelops:\n")
#  cat(" - variog.env.model:\n")
#  cat("       the same as the previous variog.env, based on the model")
#  cat(" - variog.env.mc:\n")
#  cat("       the new one based on permutations of the data")
#  return(invisible())
#}

"variog.model.env" <-
  function(geodata, coords = geodata$coords, obj.variog,
           model.pars, nsim = 99, save.sim = FALSE,
           messages.screen = TRUE) 
{
  call.fc <- match.call()
  obj.variog$v <- NULL
  ##
  ## reading input
  ##
  if(!is.null(model.pars$beta)) beta <- model.pars$beta
  else beta <- 0
  if(!is.null(model.pars$cov.model))
    cov.model <- model.pars$cov.model
  else cov.model <- "exponential"
  if(!is.null(model.pars$kappa)) kappa <- model.pars$kappa
  else kappa <- 0.5
  if(!is.null(model.pars$nugget)) nugget <- model.pars$nugget
  else nugget <- 0
  cov.pars <- model.pars$cov.pars
  if(!is.null(obj.variog$estimator.type))
    estimator.type <- obj.variog$estimator.type
  else estimator.type <- "classical"
  if (obj.variog$output.type != "bin") 
    stop("envelops can be computed only for binned variogram")
  ##
  ## generating simulations from the model with parameters provided
  ##
  if (messages.screen) 
    cat(paste("variog.env: generating", nsim, "simulations (with ",
              obj.variog$n.data, 
              "points each) using the function grf\n"))
  simula <- grf(obj.variog$n.data, grid = as.matrix(coords),
                cov.model = cov.model, cov.pars = cov.pars,
                nugget = nugget, kappa = kappa, nsim = nsim,
                messages.screen = FALSE, lambda = obj.variog$lambda)
  if(messages.screen)
    cat("variog.env: adding the mean or trend\n")
  x.mat <- trend.spatial(trend=obj.variog$trend, coords=coords)
  simula$data <- as.vector(x.mat %*% beta) + simula$data
  ##
  ## computing empirical variograms for the simulations
  ##
  if (messages.screen) 
    cat(paste("variog.env: computing the empirical variogram for the", 
              nsim, "simulations\n"))
  nbins <- length(obj.variog$bins.lim) - 1
  if(is.R()){
    bin.f <- function(sim){
      cbin <- vbin <- sdbin <- rep(0, nbins)  
      temp <- .C("binit",
                 as.integer(obj.variog$n.data),
                 as.double(as.vector(coords[,1])),
                 as.double(as.vector(coords[,2])),
                 as.double(as.vector(sim)),
                 as.integer(nbins),
                 as.double(as.vector(obj.variog$bins.lim)),
                 as.integer(estimator.type == "robust"),
                 as.double(max(obj.variog$u)),
                 as.double(cbin),
                 vbin = as.double(vbin),
                 as.integer(FALSE),
                 as.double(sdbin)
                 )$vbin
      return(temp)
    }
    simula.bins <- apply(simula$data, 2, bin.f)
    simula.bins <- simula.bins[obj.variog$ind.bin,]
  }
  else{
    bin.f <- function(sim, nbins, n.data, coords, bins.lim, estimator.type, max.u){
      cbin <- vbin <- sdbin <- rep(0, nbins)  
      temp <- .C("binit",
                 as.integer(n.data),
                 as.double(as.vector(coords[,1])),
                 as.double(as.vector(coords[,2])),
                 as.double(as.vector(sim)),
                 as.integer(nbins),
                 as.double(as.vector(bins.lim)),
                 as.integer(estimator.type == "robust"),
                 as.double(max.u),
                 as.double(cbin),
                 vbin = as.double(vbin),
                 as.integer(FALSE),
                 as.double(sdbin)
                 )$vbin
      return(temp)
    }
    simula.bins <- apply(simula$data, 2, bin.f, nbins=nbins, n.data=obj.variog$n.data, coords=coords, bins.lim=obj.variog$bins.lim, estimator.type=estimator.type, max.u=max(obj.variog$u))
    simula.bins <- simula.bins[obj.variog$ind.bin,]
  }
  if(save.sim == FALSE) simula$data <- NULL
  ##
  ## computing envelops
  ##
  if (messages.screen) 
    cat("variog.env: computing the envelops\n")
  limits <- apply(simula.bins, 1, range)
  res.env <- list(u = obj.variog$u, v.lower = limits[1, ],
                  v.upper = limits[2,])
  if(save.sim) res.env$simulated <- simula$data
  res.env$call <- call.fc
  class(res.env) <- "variogram.envelope"
  return(res.env)
}

"variog.mc.env" <-
  function (geodata, coords = geodata$coords, data = geodata$data,
            obj.variog, nsim = 99, save.sim = FALSE,
            messages.screen = TRUE) 
{
  call.fc <- match.call()
  ##
  ## Checking input
  ##
  obj.variog$v <- NULL
  if((is.matrix(data) | is.data.frame(data)))
    if(ncol(data) > 1)
      stop("envelops can be computed for only one data set at once")
  if(!is.null(obj.variog$estimator.type))
    estimator.type <- obj.variog$estimator.type
  else estimator.type <- "classical"
  ##
  ## generating several "data-sets" by permutating data values
  ##
  if (messages.screen) 
    cat(paste("variog.env: generating", nsim,
              "simulations by permutating data values\n"))
  simula <- list(coords = coords)
  n.data <- length(data)
  perm.f <- function(i, data, n.data){return(data[sample(1:n.data)])}
  simula$data <- apply(as.matrix(1:nsim),1, perm.f, data=data, n.data=n.data) 
  ##
  ## computing empirical variograms for the simulations
  ##
  if (messages.screen) 
    cat(paste("variog.env: computing the empirical variogram for the", 
              nsim, "simulations\n"))
  nbins <- length(obj.variog$bins.lim) - 1
  if(is.R()){
    bin.f <- function(sim){
      cbin <- vbin <- sdbin <- rep(0, nbins)  
      temp <- .C("binit",
                 as.integer(obj.variog$n.data),
                 as.double(as.vector(coords[,1])),
                 as.double(as.vector(coords[,2])),
                 as.double(as.vector(sim)),
                 as.integer(nbins),
                 as.double(as.vector(obj.variog$bins.lim)),
                 as.integer(estimator.type == "robust"),
                 as.double(max(obj.variog$u)),
                 as.double(cbin),
                 vbin = as.double(vbin),
                 as.integer(FALSE),
                 as.double(sdbin)
                 )$vbin
      return(temp)
    }
    simula.bins <- apply(simula$data, 2, bin.f)
    simula.bins <- simula.bins[obj.variog$ind.bin,]
  }
  else{
    bin.f <- function(sim, nbins, n.data, coords, bins.lim, estimator.type, max.u){
      cbin <- vbin <- sdbin <- rep(0, nbins)  
      temp <- .C("binit",
                 as.integer(n.data),
                 as.double(as.vector(coords[,1])),
                 as.double(as.vector(coords[,2])),
                 as.double(as.vector(sim)),
                 as.integer(nbins),
                 as.double(as.vector(bins.lim)),
                 as.integer(estimator.type == "robust"),
                 as.double(max.u),
                 as.double(cbin),
                 vbin = as.double(vbin),
                 as.integer(FALSE),
                 as.double(sdbin)
                 )$vbin
      return(temp)
    }
    simula.bins <- apply(simula$data, 2, bin.f, nbins=nbins, n.data=obj.variog$n.data, coords=coords, bins.lim=obj.variog$bins.lim, estimator.type=estimator.type, max.u=max(obj.variog$u))
    simula.bins <- simula.bins[obj.variog$ind.bin,]
  }
  if(save.sim == FALSE) simula$data <- NULL
  ##
  ## computing envelops
  ##
  if (messages.screen) 
    cat("variog.env: computing the envelops\n")
  limits <- apply(simula.bins, 1, range)
  res.env <- list(u = obj.variog$u, v.lower = limits[1, ],
                  v.upper = limits[2,])
  if(save.sim) res.env$simulations <- simula$data
  res.env$call <- call.fc
  class(res.env) <- "variogram.envelope"
  return(res.env)
}

"lines.variogram.envelope" <-
  function(obj, lty=3, ...)
{
  lines(obj$u, obj$v.lower, ...)
  lines(obj$u, obj$v.upper, ...)
  return(invisible())
}

"varcov.spatial" <-
  function (coords = NULL, dists.lowertri = NULL, cov.model = "matern",
            kappa = 0.5, nugget = 0, cov.pars = stop("no cov.pars argument"), 
            inv = FALSE, det = FALSE,
            func.inv = c("cholesky", "eigen", "svd", "solve"),
            scaled = FALSE, only.decomposition = FALSE, 
            sqrt.inv = FALSE, try.another.decomposition = TRUE,
            only.inv.lower.diag = FALSE) 
{
  if (is.R()) 
    require(mva)
  func.inv <- match.arg(func.inv)
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  if (only.inv.lower.diag) 
    inv <- TRUE
  if (is.null(coords) & is.null(dists.lowertri)) 
    stop("one of the arguments, coords or dists.lowertri must be provided")
  if (!is.null(coords) & !is.null(dists.lowertri)) 
    stop("only ONE argument, either coords or dists.lowertri must be provided")
  if (!is.null(coords)) 
    n <- nrow(coords)
  if (!is.null(dists.lowertri)) {
    n <- as.integer(round(0.5 * (1 + sqrt(1 + 8 * length(dists.lowertri)))))
  }
  tausq <- nugget
  if (is.vector(cov.pars)) {
    sigmasq <- cov.pars[1]
    phi <- cov.pars[2]
  }
  else {
    sigmasq <- cov.pars[, 1]
    phi <- cov.pars[, 2]
  }
##  print(c(tausq=tausq, sigmasq=sigmasq, phi=phi, kappa=kappa))
  if (!is.null(coords)) {
    dists.lowertri <- as.vector(dist(coords))
  }
  if (round(1e+12 * min(dists.lowertri)) == 0) 
    warning("Two or more pairs of data at coincident (or very close) locations. \nThis can cause matrices operations to crash!\n")
  varcov <- matrix(0, n, n)
  if (scaled) {
    if (all(phi < 1e-12)) 
      varcov <- diag(x = (1 + (tausq/sum(sigmasq))), n)
    else {
      if (is.vector(cov.pars)) 
        cov.pars.sc <- c(1, phi)
      else cov.pars.sc <- cbind(1, phi)
      covvec <- cov.spatial(obj = dists.lowertri, cov.model = cov.model, 
                            kappa = kappa, cov.pars = cov.pars.sc)
      varcov[lower.tri(varcov)] <- covvec
      varcov <- t(varcov)
      varcov[lower.tri(varcov)] <- covvec
      if (is.R()) remove("covvec")
      else remove("covvec", frame = sys.nframe())
      diag(varcov) <- 1 + (tausq/sum(sigmasq))
    }
  }
  else {
    if (all(sigmasq < 1e-10) | all(phi < 1e-10)) {
      varcov <- diag(x = (tausq + sum(sigmasq)), n)
    }
    else {
      covvec <- cov.spatial(obj = dists.lowertri, cov.model = cov.model, 
                            kappa = kappa, cov.pars = cov.pars)
      varcov[lower.tri(varcov)] <- covvec
      varcov <- t(varcov)
      varcov[lower.tri(varcov)] <- covvec
      if (is.R()) remove("covvec")
      else remove("covvec", frame = sys.nframe())
      diag(varcov) <- tausq + sum(sigmasq)
    }
  }
  if (inv | det | only.decomposition | sqrt.inv | only.inv.lower.diag) {
    if (func.inv == "cholesky") {
      options(show.error.messages = FALSE)
      varcov.sqrt <- try(chol(varcov))
      options(show.error.messages = TRUE)
      if (!is.numeric(varcov.sqrt)) {
        if (try.another.decomposition) 
          func.inv <- "eigen"
        else {
          print(varcov.sqrt[1])
          stop()
        }
      }
      else {
        if (only.decomposition | inv) 
          if (is.R()) remove("varcov")
          else remove("varcov", frame = sys.nframe())
        if (only.decomposition == FALSE) {
          if (det) 
            cov.logdeth <- sum(log(diag(varcov.sqrt)))
          if (sqrt.inv) 
            inverse.sqrt <- solve(varcov.sqrt)
          if (inv) {
            if (is.R()) {
              invcov <- chol2inv(varcov.sqrt)
              if (!sqrt.inv)
                remove("varcov.sqrt")
            }
            else {
              invcov.sqrt <- solve.upper(varcov.sqrt)
              invcov <- invcov.sqrt %*% t(invcov.sqrt)
              if (!sqrt.inv) 
                remove("varcov.sqrt", frame = sys.nframe())
            }
          }
        }
      }
    }
    if (func.inv == "svd") {
      varcov.svd <- svd(varcov, nv = 0)
      options(show.error.messages = FALSE)
      cov.logdeth <- try(sum(log(sqrt(varcov.svd$d))))
      options(show.error.messages = TRUE)
      if (is.numeric(cov.logdeth)) {
        if (try.another.decomposition) 
          func.inv <- "eigen"
        else {
          print(cov.logdeth[1])
          stop()
        }
      }
      else {
        if (only.decomposition | inv) 
          if (is.R())  remove("varcov")
          else remove("varcov", frame = sys.nframe())
        if (only.decomposition) 
          varcov.sqrt <- t(varcov.svd$u %*% (t(varcov.svd$u) * 
                                             sqrt(varcov.svd$d)))
        if (inv) {
          invcov <- t(varcov.svd$u %*% (t(varcov.svd$u) * 
                                        (1/varcov.svd$d)))
        }
        if (sqrt.inv) 
          inverse.sqrt <- t(varcov.svd$u %*% (t(varcov.svd$u) * 
                                              (1/sqrt(varcov.svd$d))))
      }
    }
    if (func.inv == "solve") {
      if (det) 
        stop("the option func.inv == \"solve\" does not allow computation of determinants. \nUse func.inv = \"chol\",\"svd\" or \"eigen\"\n")
      options(show.error.messages = FALSE)
      invcov <- try(solve(varcov))
      options(show.error.messages = TRUE)
      if (is.numeric(cov.logdeth)) {
        if (try.another.decomposition) 
          func.inv <- "eigen"
        else {
          print(invcov[1])
          stop()
        }
      }
      if (is.R()) remove("varcov")
      else remove("varcov", frame = sys.nframe())
    }
    if (func.inv == "eigen") {
      options(show.error.messages = FALSE)
      varcov.eig <- try(eigen(varcov, symmetric = TRUE))
      cov.logdeth <- try(sum(log(sqrt(varcov.eig$val))))
      options(show.error.messages = TRUE)
      if (!is.numeric(cov.logdeth) | is.numeric(varcov.eig)) {
        diag(varcov) <- 1.0001 * diag(varcov)
        options(show.error.messages = FALSE)
        varcov.eig <- try(eigen(varcov, symmetric = TRUE))
        cov.logdeth <- try(sum(log(sqrt(varcov.eig$val))))
        options(show.error.messages = TRUE)
        if (!is.numeric(cov.logdeth) | !is.numeric(varcov.eig)) {
          return(list(crash.parms = c(tausq=tausq, sigmasq=sigmasq, phi=phi, kappa=kappa)))
        }
      }
      else {
        if (only.decomposition | inv) 
          if (is.R()) remove("varcov")
          else remove("varcov", frame = sys.nframe())
        if (only.decomposition) 
          varcov.sqrt <- (varcov.eig$vec %*% diag(sqrt(varcov.eig$val)) %*% 
                          t(varcov.eig$vec))
        if (inv) 
          invcov <- (varcov.eig$vec %*% diag(1/varcov.eig$val) %*% 
                     t(varcov.eig$vec))
        if (sqrt.inv) 
          inverse.sqrt <- (varcov.eig$vec %*% diag(1/sqrt(varcov.eig$val)) %*% 
                           t(varcov.eig$vec))
      }
    }
  }
  if (only.decomposition == FALSE) {
    if (det) {
      if (inv) {
        if (only.inv.lower.diag) 
          result <- list(lower.inverse = invcov[lower.tri(invcov)], 
                         diag.inverse = diag(invcov), log.det.to.half = cov.logdeth)
        else result <- list(inverse = invcov, log.det.to.half = cov.logdeth)
      }
      else {
        result <- list(varcov = varcov, log.det.to.half = cov.logdeth)
      }
      if (sqrt.inv) 
        result$sqrt.inverse <- inverse.sqrt
    }
    else {
      if (inv) {
        if (only.inv.lower.diag) 
          result <- list(lower.inverse = invcov[lower.tri(invcov)], 
                         diag.inverse = diag(invcov))
        else {
          if (sqrt.inv) 
            result <- list(inverse = invcov, sqrt.inverse = inverse.sqrt)
          else result <- list(inverse = invcov)
        }
      }
      else result <- list(varcov = varcov)
    }
  }
  else result <- list(sqrt.varcov = varcov.sqrt)
  result$crash.parms <- NULL
  return(result)
}

"plot.geodata" <-
  function (geodata, coords = geodata$coords, data = geodata$data, 
            trend = "cte", lambda = 1, col.data = 1,
            weights.divide = NULL, window.new = FALSE, ...) 
{
  if (is.R()) 
    par.ori <- par(no.readonly = TRUE)
  else par.ori <- par()
  on.exit(par(par.ori))
  coords <- as.matrix(geodata$coords)
  data <- as.matrix(data)
  data <- data[, col.data]
  if (window.new) {
    if (is.R()) 
      X11()
    else trellis.device()
  }
  if (lambda != 1) {
    if (lambda == 0) 
      data <- log(data)
    else data <- ((data^lambda) - 1)/lambda
  }
  if (!is.null(weights.divide)) {
    if (length(weights.divide) != length(data)) 
      stop("length of weights.divide must be equals to the length of data")
    data <- data/weights.divide
  }
  par(mfrow = c(2, 2))
  par(mar = c(4, 4, 0, 0.5))
  data.quantile <- quantile(data)
  coords.lims <- set.coords.lims(coords=coords)
  par(pty = "s")
  plot(coords, xlab = "Coord X", ylab = "Coord Y", type = "n", 
       xlim = coords.lims[, 1], ylim = coords.lims[, 2])
  if (is.R()) {
    data.breaks <- unique(quantile(data))
    n.breaks <- length(data.breaks)
    data.cut <- cut(data, breaks = data.breaks, include.l = TRUE, 
                    labels = FALSE)
#    points(coords, cex = c(0.4,0.6, 0.9, 1.2)[data.cut], pch=21, bg=c("blue", "green", "yellow2", "red")[data.cut])
    points(coords, pch = (1:4)[data.cut], col=c("blue", "green", "yellow2", "red")[data.cut])
  }
  else {
    points(coords[(data <= data.quantile[2]), ], pch = 1, 
           cex = 0.6, col = 2)
    points(coords[((data > data.quantile[2]) & (data <= 
                                                data.quantile[3])), ], pch = 2, cex = 1.4, col = 4)
    points(coords[((data > data.quantile[3]) & (data <= 
                                                data.quantile[4])), ], pch = 3, cex = 1.7, col = 7)
    points(coords[(data > data.quantile[4]), ], pch = 4, 
           cex = 2, col = 8)
  }
  par(pty = "m")
  if (is.R()) 
    par(mar = c(4, 4, 1, 1))
  else par(mar = c(0, 1, 0, 0.5))
  if (is.R()) {
    if (require(scatterplot3d) == FALSE) {
      hist(data)
      cat("plot.geodata: a 3d plot would be drawn instead of the histogram if the package \"scatterplot3d\" is available\n")
    }
    else scatterplot3d(x = coords[, 1], y = coords[, 2], 
                       z = data, box = F, type = "h", pch = 16, xlab = "Coord X", 
                       ylab = "Coord Y", ...)
  }
  else xyzplot(coords = coords, data = data, ...)
  if (!is.R()) 
    par(mar = c(5, 5, 1, 0.5))
  plot(coords[, 1], data, xlab = "Coord X", cex = 1)
  plot(coords[, 2], data, xlab = "Coord Y", cex = 1)
  return(invisible())
}


"set.coords.lims" <-
  function(coords)
  {
    coords.lims <- apply(coords, 2, range)
    coords.diff <- diff(coords.lims)
    if (coords.diff[1] != coords.diff[2]) {
      coords.diff.diff <- abs(diff(as.vector(coords.diff)))
      ind.min <- which(coords.diff == min(coords.diff))
      coords.lims[, ind.min] <- coords.lims[, ind.min] + c(-coords.diff.diff, 
                                                           coords.diff.diff)/2
    }
    return(coords.lims)
  }
"krige.bayes" <- 
  function(geodata, coords=geodata$coords, data=geodata$data, locations = "no",
           model = model.control(
             trend.d = "cte", trend.l = "cte", cov.model = "matern",
             kappa = 0.5, aniso.pars = NULL, lambda = 1), 
           prior = prior.control(
             beta.prior = c("flat", "normal", "fixed"),
             beta = NULL, beta.var = NULL,
             sill.prior = c("reciprocal", "fixed"), sill = NULL, 
             range.prior = c("uniform", "exponential", "fixed",
               "squared.reciprocal","reciprocal"),
             exponential.prior.par = 1,
             range = NULL, range.discrete = NULL, 
             nugget.rel.prior = c("fixed", "uniform"),
             nugget.fixed  = 0,
             nugget.rel.discrete = NULL),
           output = output.control(
             n.posterior = 1000, n.predictive = NULL, moments = TRUE,
             simulations.predictive = TRUE, keep.simulations = TRUE,
             mean.estimator = TRUE, quantile.estimator = NULL,
             probability.estimator = NULL, signal = TRUE, 
             messages.screen = TRUE)
           )
{
  ##           smaller.locations = NULL, trend.smaller.l = model$trend.l
  ##
######################### PART 1 ##############################
  ## Input check
  ##
  if(is.R()) require(mva)
  call.fc <- match.call()
  seed <- .Random.seed
  kb.results <- list(posterior = list(), predictive=list())
  ##
  ## reading input
  ##
  cov.model <- model$cov.model
  cov.model.number <- cor.number(cov.model)
  kappa <- model$kappa
  if(cov.model == "powered.exponential" & (kappa <= 0 | kappa > 2))
    stop("krige.bayes: for power exponential correlation model the parameter kappa must be in the interval \(0,2\]")
  lambda <- model$lambda
  ##
  beta <- prior$beta
  beta.var <- prior$beta.var
  sill <- prior$sill
  ##range <- prior$range
  nugget <- prior$nugget.fixed
  exponential.prior.par <- prior$exponential.prior.par  
  ##
  n.posterior <- output$n.posterior
  n.predictive <- output$n.predictive
  moments <- output$moments    
  messages.screen <- output$messages.screen    
  ##
  ## checking data configuration
  ##
  if(is.vector(coords)){
    coords <- cbind(coords, 0)
    warning("krige.bayes: vector of coordinates: one spatial dimention assumed")
  }
  coords <- as.matrix(coords)
  data.dist <- as.vector(dist(coords))
  data.dist.range <- range(data.dist)
  data.dist.min <- data.dist.range[1]
  data.dist.max <- data.dist.range[2]
  ## check == here
  if(round(1e12*data.dist.min) == 0)
    stop("krige.bayes: this function does not allow two data at same location")
  if(all(locations == "no")) {
    if(prior$beta.prior != "fixed" & prior$sill.prior != "fixed"  & prior$range.prior != "fixed")
      if(messages.screen){
        cat("krige.bayes: no prediction locations provided.\n")
        cat("             Only samples of the posterior for the parameters will be returned. \n ")
      }
      else
        stop("krige.bayes: no prediction locations provided and fixed parameters.\n If priors are specified for beta, sill and range sample of the posterior will be returned.")
  }
  ##  if(!is.null(smaller.locations)){
  ##    if(if(is.R()) require(akima) == FALSE)
  ##      stop("package \"akima\" is needed if a non-null object is provided in the argument \"smaller.grid\"")
  ##  }
  ##
  ## Cheking priors input
  ##
  if(prior$beta.prior == "fixed" & prior$sill.prior != "fixed")
    stop("krige.bayes: option for fixed beta and random sill not implemented\n")
  if(prior$beta.prior == "fixed" & prior$range.prior != "fixed")
    stop("krige.bayes: option for fixed beta and random range not implemented\n")
  if(prior$sill.prior == "fixed" & prior$range.prior != "fixed")
    stop("krige.bayes: option for fixed sill and random range not implemented\n")
  if(prior$beta.prior != "flat" & prior$sill.prior != "fixed")
    stop("krige.bayes: selected prior for beta not allowed for selected prior for sill\n")
  if(prior$beta.prior == "fixed" & is.null(beta))
    stop("krige.bayes: if beta is fixed, its value must be provided in the argument beta\n")
  if(prior$beta.prior == "normal" & (is.null(beta) | is.null(beta.var)))
    stop("krige.bayes: if the prior for beta is normal, the prior mean(s) and prior (co)variance must be provided using the argument beta and priorr$beta.var\n")
  if(prior$sill.prior == "fixed" & is.null(sill))
    stop("krige.bayes: if sill is fixed, its value must be provided in the argument sill\n")
  if(prior$range.prior == "fixed" & is.null(prior$range))
    stop("krige.bayes: if range is fixed, its value must be provided in the argument range\n")
  if(prior$range.prior != "fixed"){
    if (is.null(prior$range.discrete))
      stop("krige.bayes: to include the range as random in the Bayesian analysis the argument range.discrete must be provided\n")
    discrete.diff <- diff(prior$range.discrete)
    if(round(max(1e08 * discrete.diff)) != round(min(1e08 * discrete.diff)))
      stop("krige.bayes: the current implementation requires equally spaced values in the argument \"range.discrete\"\n")
    discrete.diff <- NULL
    if(is.R()) gc(verbose=FALSE)
  }    
  if(prior$nugget.rel.prior != "fixed"){
    if(is.null(prior$nugget.rel.discrete))
      stop("krige.bayes: to include the nugget as random in the Bayesian analysis the argument nugget.rel.discrete must be provided\n")
    if(any(prior$nugget.rel.discrete > 1))
      warning("krige.bayes: when nugget is considered as random in the Bayesian analysis the values in the argument nugget.rel.discrete must be relative nugget: tausq/sigmasq\n")
    discrete.diff <- diff(prior$nugget.rel.discrete)
    if(round(max(1e08 * discrete.diff)) != round(min(1e08 * discrete.diff)))
      stop("krige.bayes: the current implementation requires equally spaced values in the argument \"nugget.rel.discrete\"\n")
    discrete.diff <- NULL
    if(is.R()) gc(verbose=FALSE)
  }
  ##
  ## checking output options
  ##
  if(!is.null(output$quantile.estimator)){
    if(is.numeric(output$quantile.estimator))
      if(any(output$quantile.estimator) < 0 | any(output$quantile.estimator) > 1)
        stop("krige.bayes: quantiles indicators must be numbers in the interval [0,1]\n"
             )
    if(output$quantile.estimator == TRUE)
      output$quantile.estimator <- c(0.025000000000000001, 0.5, 0.97499999999999998)
  }
  if(!is.null(output$probability.estimator)){
    if(!is.numeric(output$probability.estimator))
      stop("krige.bayes: probability.estimator must be a numeric value (or vector) of cut-off value(s)\n")
    if(length(output$probability.estimator)>1 & length(output$probability.estimator) != nrow(locations))
      stop("krige.bayes: probability.estimator must either have length 1, or have length = nrow(locations)\n")
  }
  if(lambda != 1 & lambda != 0 & moments) {
    moments <- FALSE
    cat(paste("WARNING: moments cannot be computed with lambda = ", 
              lambda,".\n         Argument moments was set to FALSE\n",
              sep=""))
  }
  if(lambda < 0 & output$mean.estimator) {
    output$mean.estimator <- FALSE
    cat("krige.bayes: mean.predictor set to FALSE.\n             The resulting distribution does not has expectation for lambda < 0\n"
        )
  }
  ##
  ## Box-Cox transformation of the data
  ##
  if(lambda != 1) {
    if(prior$range.prior == "fixed")
      stop("krige.bayes: transformation option available only for the full Bayesian approach"
           )
    if(messages.screen)
      cat(paste("krige.bayes: Box-Cox's transformation performed for lambda =", lambda, "\n"))
    if(lambda == 0)
      data <- log(data)
    else data <- ((data^lambda) - 1)/lambda
  }
  ##
  ## Checking the dimension of points to be predict (1 or 2)	
  ##
  if(all(locations != "no")) {
    if(is.vector(locations)) {
      if(length(locations) == 2) {
        locations <- t(as.matrix(locations))
        warning("krige.bayes: THE FUNCTION IS CONSIDERING THAT YOU HAVE ENTERED WITH 1 POINT TO BE PREDICTED IN A TWO DIMENSION REGION\n")
      }
      else locations <- as.matrix(cbind(locations, 0))
    }
    else locations <- as.matrix(locations)
  }
  ##
  ## Building trend matrices:	
  ##
  if(inherits(model$trend.d, "formula") | inherits(model$trend.l, "formula")){
    if(any(locations != "no"))
      if((inherits(model$trend.d, "formula") == FALSE) | (inherits(model$trend.l, "formula") == FALSE))
        stop("krige.bayes: model$trend.d and model$trend.l must have similar specification\n")
    if(messages.screen)
      cat("krige.bayes: Kriging with external trend to be performed using covariates provided by the user\n")
  }
  else{
    if (any(locations != "no") & (model$trend.d != model$trend.l)){
      stop("krige.bayes: model$trend.l is different from model$trend.d")
    }
    if(messages.screen){
      if(model$trend.d == "cte")
        cat("krige.bayes: analysis assuming a constant mean\n")
      if(model$trend.d == "1st")
        cat("krige.bayes: analysis assuming a 1st degree polinomial trend\n")
      if(model$trend.d == "2nd") 
        cat("krige.bayes: analysis assuming a 2nd degree polinomial trend\n")
    }
  }
  trend.data <- trend.spatial(trend=model$trend.d, coords=coords)
  dimnames(coords) <- list(NULL, NULL)
  dimnames(trend.data) <- list(NULL, NULL)
  if(all(locations != "no")) {
    trend.l <- trend.spatial(trend=model$trend.l, coords=locations)
    dimnames(locations) <- list(NULL, NULL)
    dimnames(trend.l) <- list(NULL, NULL)
    if(is.matrix(trend.l))
      ni <- dim(trend.l)[1]
    else ni <- length(trend.l)
    ##    if(!is.null(smaller.locations)){
    ##      trend.smaller.l <- trend.spatial(trend=model$trend.l, coords=smaller.locations)
    ##    }
  }
  beta.size <- ncol(trend.data)
  ##
  ## Checking dimensions
  ##
  if(nrow(coords) != length(data)) stop(
           "krige.bayes: number of data is different of number of data locations (coordinates)"
           )
  if(all(locations != "no")) {
    if(nrow(locations) != nrow(trend.l))
      stop("krige.bayes: number of points to be estimated is different of the number of trend points"
           )
    dimnames(locations) <- list(NULL, NULL)
  }
  dimnames(coords) <- list(NULL, NULL)
  ##
  ## Anisotropy correction (must be placed here after trend matrices be defined)
  ##
  if(!is.null(model$aniso.pars)) {
    if(length(model$aniso.pars) != 2 | !is.numeric(model$aniso.pars))
      stop("krige.bayes: anisotropy parameters must be provided as a numeric vector with two elements: the rotation angle and the anisotropy ratio\n")
    if(messages.screen)
      cat("krige.bayes: anisotropy parameters provided and assumed to be constants\n")
    coords <- coords.aniso(coords = coords, aniso.pars = model$aniso.pars)
    if(all(locations != "no"))
      locations <- coords.aniso(coords = locations, 
				aniso.pars = model$aniso.pars)
    data.dist <- as.vector(dist(coords))
  }
  ##
  n <- length(data)
  tausq <- nugget
  if(prior$sill.prior != "fixed") sigmasq <- 1
  else sigmasq <- sill
  ##
######################### PART 2 ##############################
  ## Prediction with fixed phi
  ##
  if(prior$range.prior == "fixed"){
    phi <- prior$range
    ## covariance matrix for data points
    invcov <- varcov.spatial(dists.lowertri=data.dist, cov.model = cov.model,
                             kappa = kappa, nugget = nugget,
                             cov.pars = c(sigmasq, phi), inv = TRUE,
                             scaled=TRUE, only.inv.lower.diag = TRUE)
    remove("data.dist")
    if(is.R()) gc(verbose=FALSE)
    ## Some matrices computations
###    ttiv <- crossprod(trend.data, invcov)
###    ttivtt <- ttiv %*% trend.data
###    ittivtt <- solve(ttivtt)
    ttivtt <- as.double(rep(0, beta.size * beta.size))
    ttivtt <- .C("bilinearform_XAY",
                 as.double(invcov$lower.inverse),
                 as.double(invcov$diag.inverse),
                 as.double(as.vector(trend.data)),
                 as.double(as.vector(trend.data)),
                 as.integer(beta.size),
                 as.integer(beta.size),
                 as.integer(n),
                 res=ttivtt)$res
    attr(ttivtt, "dim") <- c(beta.size, beta.size)
    ittivtt <- solve(ttivtt)
###    ttivz <- ttiv %*% data
    ttivz <- as.double(rep(0, beta.size))
    ttivz <- .C("bilinearform_XAY",
                as.double(invcov$lower.inverse),
                as.double(invcov$diag.inverse),
                as.double(as.vector(trend.data)),
                as.double(as.vector(data)),
                as.integer(beta.size),
                as.integer(1),
                as.integer(n),
                res=ttivz)$res
    ## covariance vector between data points and prediction locations
    v0mat <- as.double(rep(0, n*ni))
    .C("loccoords",
       as.double(as.vector(locations[,1])),
       as.double(as.vector(locations[,2])),
       as.double(as.vector(coords[,1])),
       as.double(as.vector(coords[,2])),
       as.integer(ni),
       as.integer(n),
       v0mat, DUP=FALSE)
    attr(v0mat, "dim") <- c(n, ni)
    v0mat <- cov.spatial(obj = v0mat,
                         cov.model = cov.model,
                         kappa = kappa, cov.pars = c(1, phi))
###    tv0iv <- t(apply(v0mat, 2, crossprod, y = invcov))
###    tv0ivz <- tv0iv %*% data
    tv0ivz <- as.double(rep(0,ni))
    tv0ivz <- .C("bilinearform_XAY",
                 as.double(invcov$lower.inverse),
                 as.double(invcov$diag.inverse),
                 as.double(as.vector(v0mat)),
                 as.double(data),
                 as.integer(ni),
                 as.integer(1),
                 as.integer(n),
                 res = tv0ivz)$res
###    tv0ivx <- apply(tv0iv, 1, crossprod, y = trend.data)
    tv0ivx <- as.double(rep(0, ni*beta.size))
    tv0ivx <- .C("bilinearform_XAY",
                 as.double(invcov$lower.inverse),
                 as.double(invcov$diag.inverse),
                 as.double(as.vector(v0mat)),
                 as.double(as.vector(trend.data)),
                 as.integer(ni),
                 as.integer(beta.size),
                 as.integer(n),
                 res=tv0ivx)$res
    attr(tv0ivx, "dim") <- c(ni, beta.size)
    tb <- trend.l - tv0ivx
                                        #    b <- t(tb)
###    tv0ivv0 <- diag(tv0iv %*% v0mat)
    tv0ivv0 <- as.double(rep(0,ni))
    tv0ivv0 <- .C("diag_quadraticform_XAX",
                  as.double(invcov$lower.inverse),
                  as.double(invcov$diag.inverse),
                  as.double(as.vector(v0mat)),
                  as.integer(ni),
                  as.integer(n),
                  res = tv0ivv0)$res
    v0mat <- NULL
    if(is.R()) gc(verbose=FALSE)
    ##
########################## PART 2.1 ##############################
    ## Simple kriging (fixed beta and sigmasq)
    ##
    if(prior$beta.prior == "fixed") {
      beta.mean <- paste("SK : beta provided by user: ",
                         beta)
      kb.results$predictive$mean <- as.vector(tv0ivz + as.vector(tb %*% beta))
      if(output$signal)
        kb.results$predictive$variance <- as.vector(sigmasq * (1 - tv0ivv0))
      else kb.results$predictive$variance <- as.vector(nugget + sigmasq * (1 - tv0ivv0))
      priors.messa <- c("no priors for parameters", 
                        "results corresponds to simple kriging")
      sill.mean <- paste("sill provided by user: ", sill)
    }
    ##
######################### PART 2.2 ##################################
    ## uncertainty in beta and sigmasq
    ##
    if(prior$beta.prior == "flat") {
      beta.mean <- ittivtt %*% ttivz
###      predict <- tv0ivz + b %*% beta.mean
      kb.results$predictive$mean <- as.vector(tv0ivz + as.vector(tb %*% beta.mean))
      ##      bi <- apply(tb, 2, crossprod, y = ittivtt)
      ##      if(ncol(trend.data) > 1)
      ##        bi <- t(bi)
      ##      bitb <- diag(bi %*% tb)
      if(beta.size == 1)
        bitb <- as.vector(tb^2) * as.vector(ittivtt)
      else{
        bitb <- as.double(rep(0,ni))
        bitb <- .C("diag_quadraticform_XAX",
                   as.double(ittivtt[lower.tri(ittivtt)]),
                   as.double(diag(ittivtt)),
                   as.double(as.vector(t(tb))),
                   as.integer(ni),
                   as.integer(beta.size),
                   res = bitb)$res
      }
      if(prior$sill.prior == "fixed") {
        ##
        ## 2.2.1 Ordinary kriging: uncertainty only in beta, flat prior
        ##
        if(output$signal)
          kb.results$predictive$variance <- as.vector(sigmasq * (1 - tv0ivv0 + bitb))
        else kb.results$predictive$variance <- as.vector(nugget + sigmasq * (1 - tv0ivv0 + bitb))
        priors.messa <- c(
                          "uninformative prior for beta", 
                          "no prior for sill", 
                          "no prior for range", 
                          "kriging estimates and variances equivalent to ordinary kriging"
                          )
        sill.mean <- paste("sill provided by user: ",
                           sill)
      }
      else {
        ##
        ## 2.2.2 using a conjugate normal prior
        ##
        residu <- as.vector(data - trend.data %*% beta.mean)
###        sill.mean <- (residu %*% invcov %*% residu)/
###          (n - length(beta.mean) - 2)
        resivres <- as.double(0)
        resivres <- .C("diag_quadraticform_XAX",
                       as.double(invcov$lower.inverse),
                       as.double(invcov$diag.inverse),
                       as.double(residu),
                       as.integer(1),
                       as.integer(n),
                       res = resivres)$res
        sill.mean <- resivres / (n - length(beta.mean) - 2)
        if(output$signal)
          kb.results$predictive$variance <- as.vector(sill.mean * (1 - tv0ivv0 + bitb))
        else kb.results$predictive$variance <- as.vector(nugget + sill.mean * (1 - tv0ivv0 + bitb))
        priors.messa <- c(
                          "uninformative prior for beta", 
                          "uninformative prior for sill", 
                          "kriging estimates (but not variances) equivalent to ordinary kriging"
                          )
      }
    }
    ##
    ## 2.2.3 Uncertainty only in the mean parameter (with normal prior)
    ##
    if(prior$beta.prior == "normal") {
      beta.var <- beta.var/sigmasq
      ibeta.var <- solve(beta.var)
      varbgz <- solve(ibeta.var + ttivtt)
      beta.mean <- varbgz %*% (ibeta.var %*% beta + ttivz)
      kb.results$predictive$mean <- as.vector(tv0ivz + as.vector(tb %*% beta.mean))
###      bi <- apply(tb, 2, crossprod, y = varbgz)
###      bitb <- diag(bi %*% tb)
      if(beta.size == 1)
        bitb <- as.vector(tb^2) * as.vector(ittivtt)
      else{
        bitb <- as.double(rep(0,ni))
        bitb <- .C("diag_quadraticform_XAX",
                   as.double(ittivtt[lower.tri(ittivtt)]),
                   as.double(diag(ittivtt)),
                   as.double(as.vector(t(tb))),
                   as.integer(ni),
                   as.integer(beta.size),
                   res = bitb)$res
      }
      if(output$signal)
        kb.results$predictive$variance <- as.vector(sigmasq * (1 - tv0ivv0) + bitb)
      else kb.results$predictive$variance <- as.vector(nugget + sigmasq * (1 - tv0ivv0) + bitb)
      priors.messa <- c("Normal prior for beta", 
                        "no prior for sill", "no prior for range")
      sill.mean <- paste("provided by user: ", sill)
    }
    ##
######################### PART 2.3 ##################################
    ## Preparing output
    ##
###    kb.results$predictive$mean <- as.vector(predict)
###    kb.results$predictive$variance <- as.vector(krige.var)
    kb.results$posterior$beta.mean <- beta.mean
    kb.results$posterior$sigmasq.mean <- sill.mean
    kb.results$posterior$phi.mean <- paste("provided by user: ", prior$range)
    kb.results$type.prediction <- priors.messa
  }
  else {
    ##	
######################### PART 3 ##############################
    ## considering the uncertainty in the parameter phi
    ##
    if(messages.screen)
      cat("krige.bayes: computing the discrete approximation of the posterior of phi/tausq.rel\n"
          )
    ##	
######################### PART 3.1 ##############################
    ## Computing the discrete posterior distribution for phi
    ##
    df.model <- as.vector(n - beta.size)
    phidist <- list()
    if(is.null(prior$range.discrete)){
      phidist$phi <- seq(0, max(data.dist), l = 51)
      warning("krige.bayes: argument range.discrete not provided. Default values assumed\n")
    }
    else
      phidist$phi <- prior$range.discrete
    if(is.null(prior$nugget.rel.discrete)){
      nugget.rel.discrete <- nugget
      if(messages.screen)
        cat(paste("krige.bayes: nugget assumed to be fixed and equals to", nugget, "\n"))
    }
    else
      nugget.rel.discrete <- prior$nugget.rel.discrete
    n.range <- length(phidist$phi)
    n.nugget <- length(nugget.rel.discrete)
    phi.val <- phidist$phi
    phidist$phi <- as.matrix(expand.grid(phidist$phi, nugget.rel.discrete))
    dimnames(phidist$phi) <- list(NULL, NULL)
    krige.bayes.aux1 <- function(phinug){
      phi <- phinug[1]
      nugget <- phinug[2]
      if(round(1e12 * phi) == 0)
        covphi <- list(inverse = diag((1/(1 + nugget)), n), 
                       log.det.to.half = ((n/2) * log(1 + nugget)))
      else 
        covphi <- varcov.spatial(dists.lowertri = data.dist, cov.model = 
                                 cov.model, kappa = kappa, nugget = nugget,
                                 cov.pars = c(1, phi), inv = TRUE, det = TRUE)
      ttiv <- crossprod(trend.data, covphi$inverse)
      ttivtt <- ttiv %*% trend.data
      vbetaphi <- solve(ttivtt)
      eival.x <- eigen(ttivtt, symmetric = TRUE, only.values = TRUE)
      ttivttdet <- prod(eival.x$values)
      betaphi <- as.vector(vbetaphi %*% ttiv %*% data)
      res <- data - trend.data %*% betaphi
      sqres <- crossprod(res, covphi$inverse) %*% res
      df.model <- length(data) - length(betaphi)
      s2phi <- (1/df.model) * sqres
      logprobphi <- (-0.5) * log(ttivttdet) - (covphi$log.det.to.half) - (
                                                                          df.model/2) * log(s2phi)
      if(prior$range.prior == "reciprocal" & round(1e+08 * phi) != 0)
        logprobphi <- logprobphi - log(phi)
      if(prior$range.prior == "squared.reciprocal" & round(1e+08 * phi) != 0)
        logprobphi <- logprobphi - log(phi^2)
      if(prior$range.prior == "exponential")
        logprobphi <- logprobphi - exponential.prior.par * phi
      inv.lower <- covphi$inverse[lower.tri(covphi$inverse)]
      inv.diag <- diag(covphi$inverse)
      return(list(vbetaphi = vbetaphi, betaphi = betaphi, s2phi = s2phi,
                  logprobphi = logprobphi, inv.lower = inv.lower, inv.diag = inv.diag))
    }
    temp.res <- apply(phidist$phi, 1, krige.bayes.aux1)
    extract.f <- function(obj){return(obj$s2phi)}
    phidist$s2 <- as.vector(sapply(temp.res, extract.f))
    attr(phidist$s2, "dim") <- c(n.range, n.nugget)
    extract.f <- function(obj){return(obj$logprobphi)}
    phidist$logprobphi <- as.vector(sapply(temp.res, extract.f))
    attr(phidist$logprobphi, "dim") <- c(n.range, n.nugget)
    extract.f <- function(obj){return(obj$inv.lower)}
    inv.lower <-  as.vector(t(sapply(temp.res, extract.f)))
    attr(inv.lower, "dim") <- c(n.range, n.nugget, (n * (n - 1))/2)
    extract.f <- function(obj){return(obj$inv.diag)}
    inv.diag <-  as.vector(t(sapply(temp.res, extract.f)))
    attr(inv.diag, "dim") <- c(n.range, n.nugget, n)
    nframe.del <- sys.nframe()
    extract.f <- function(obj){return(obj$vbetaphi)}
    if(beta.size == 1){
      phidist$vbeta.vector <- as.vector(sapply(temp.res,extract.f))
      attr(phidist$vbeta.vector, "dim") <- c(n.range, n.nugget, 1)
    }
    else{
      phidist$vbeta.vector <- as.vector(t(sapply(temp.res, extract.f)))
##      dimnames(phidist$vbeta.vector) <- list(NULL, NULL)
      attr(phidist$vbeta.vector, "dim") <- c(n.range, n.nugget, (beta.size^2))
    }
    extract.f <- function(obj){return(obj$betaphi)}
    if(beta.size == 1){
      phidist$beta <- as.vector(sapply(temp.res, extract.f))
##      dimnames(phidist$beta) <- list(NULL, NULL)
      attr(phidist$beta, "dim") <- c(n.range, n.nugget, 1)
    }
    else{
      phidist$beta <- as.vector(t(sapply(temp.res, extract.f)))
      attr(phidist$beta, "dim") <- c(n.range, n.nugget, beta.size)
    }
    temp.res <- NULL
    if(is.R()) gc(verbose=FALSE)
    phidist$logprobphi <- phidist$logprobphi + abs(min(phidist$
                                                       logprobphi))
    phidist$probphi <- exp(phidist$logprobphi)
    sumprob <- sum(phidist$probphi)
    phidist$probphi <- phidist$probphi/sumprob
    ##
######################### PART 3.2 ##############################
    ## Sampling from the (parameters) posterior distribution
    ##
    if(messages.screen) cat(
         "krige.bayes: sampling from multivariate distribution of the parameters\n"
         )
    ind <- sample((1:(n.range * n.nugget)), n.posterior, replace = 
                  T, prob = as.vector(phidist$probphi))
    ind.unique <- sort(unique(ind))
    ind.length <- length(ind.unique)
    ind.table <- table(ind)
    phi.unique <- phidist$phi[ind.unique,  ]
    if(messages.screen) {
      cat("krige.bayes: samples and their frequencies from the distribution of  phi and tau.rel\n")
      print(rbind(phi = phi.unique[, 1], nugget.rel = 
                  phi.unique[, 2], frequency = ind.table))
      cat("\n")
    }
    phi.sam <- phidist$phi[ind,  ]
    vecpars.back.order <- order(ind)
    vec.s2 <- rep(as.vector(phidist$s2)[ind.unique], ind.table)
    samples.chisq <- rchisq(n.posterior, df = df.model)
    sigmasq <- (df.model * vec.s2)/samples.chisq
    if(beta.size == 1) {
      samples.beta <- rnorm(n.posterior, mean = 0, sd = 1)
      vec.beta <- rep(as.vector(phidist$beta)[ind.unique],
                      ind.table)
      vec.vbeta <- rep(as.vector(phidist$vbeta.vector)[
                                                       ind.unique], ind.table)
      beta <- vec.beta + sqrt(sigmasq * vec.vbeta) * 
        samples.beta
    }
    else {
      ind.beta <- matrix(phidist$beta, ncol = beta.size)[
                                         ind.unique,  ]
      ind.beta <- ind.beta[rep(1:ind.length, ind.table),
                           ]
      ind.vbeta <- matrix(phidist$vbeta.vector, ncol = 
                          beta.size^2)[ind.unique,  ]
      ind.vbeta <- ind.vbeta[rep(1:ind.length, ind.table),
                             ] * sigmasq
      ##      print("2.4: try to speed up this bit!")
      temp.res <- apply(ind.vbeta, 1, krige.bayes.aux3, 
                        beta.size = beta.size)
      beta <- ind.beta + t(temp.res)
      temp.res <- NULL
      if(is.R()) gc(verbose=FALSE)
    }
    if(beta.size == 1) {
      trend.mean <- mean(beta)
      trend.median <- median(beta)
    }
    else {
      trend.mean <- apply(beta, 2, mean)
      trend.median <- apply(beta, 2, median)
    }
    sill.mean <- mean(sigmasq)
    sill.median <- median(sigmasq)
    range.marg <- apply(phidist$probphi, 1, sum)
    range.marg <- range.marg/(sum(range.marg))
    range.mean <- phi.val %*% range.marg
    range.median <- median(phi.sam[, 1])
    ## check == here
    range.mode <- phi.val[range.marg == max(range.marg)]
    nugget.marg <- apply(phidist$probphi, 2, sum)
    nugget.marg <- nugget.marg/(sum(nugget.marg))
    nugget.mean <- nugget.rel.discrete %*% nugget.marg
    nugget.median <- median(phi.sam[, 2])
    ## check == here
    nugget.mode <- nugget.rel.discrete[nugget.marg == max(nugget.marg)]
    ##
    ## Computing the conditional (on phi and tausq.rel,
    ## the later if the case) modes for beta and sigmasq
    ##
    invcov.mode <- varcov.spatial(dists.lowertri=data.dist,
                                  cov.model = cov.model,
                                  kappa = kappa, nugget = nugget.mode,
                                  cov.pars = c(1, range.mode), inv = TRUE,
                                  only.inv.lower.diag = TRUE)
    remove("data.dist")
    if(is.R()) gc(verbose=FALSE)
    ttivtt.mode <- as.double(rep(0, beta.size * beta.size))
    ttivtt.mode <- .C("bilinearform_XAY",
                      as.double(invcov.mode$lower.inverse),
                      as.double(invcov.mode$diag.inverse),
                      as.double(as.vector(trend.data)),
                      as.double(as.vector(trend.data)),
                      as.integer(beta.size),
                      as.integer(beta.size),
                      as.integer(n),
                      res=ttivtt.mode)$res
    attr(ttivtt.mode, "dim") <- c(beta.size, beta.size)
    ittivtt.mode <- solve(ttivtt.mode)
    ttivz.mode <- as.double(rep(0, beta.size))
    ttivz.mode <- .C("bilinearform_XAY",
                     as.double(invcov.mode$lower.inverse),
                     as.double(invcov.mode$diag.inverse),
                     as.double(as.vector(trend.data)),
                     as.double(as.vector(data)),
                     as.integer(beta.size),
                     as.integer(1),
                     as.integer(n),
                     res=ttivz.mode)$res
    beta.mode.cond <-  ittivtt.mode %*% ttivz.mode
    resid.mode <- as.vector(data - trend.data %*% beta.mode.cond)
    sill.mode.cond <- (.C("diag_quadraticform_XAX",
                          as.double(invcov.mode$lower.inverse),
                          as.double(invcov.mode$diag.inverse),
                          as.double(as.vector(resid.mode)),
                          as.integer(1),
                          as.integer(n),
                          res = as.double(0.0))$res)/
                            (n - length(beta.mode.cond) + 2)
    if(beta.size == 1)
      kb.results$posterior$beta.summary <- c(mean = trend.mean, median = 
                                             trend.median, mode.cond = beta.mode.cond)
    else kb.results$posterior$beta.summary <-
      cbind(mean = trend.mean, median = trend.median,
            mode.cond = beta.mode.cond)
    kb.results$posterior$sigmasq.summary <-
      c(mean = sill.mean, median = sill.median, mode.cond = sill.mode.cond)
    kb.results$posterior$phi.summary <- c(mean = range.mean, median = 
                                          range.median, mode = range.mode)
    if(prior$nugget.rel.prior != "fixed")
      kb.results$posterior$tausq.summary <- c(mean = nugget.mean,
                                              median = nugget.median,
                                              mode = nugget.mode)
    else
      kb.results$posterior$tausq.summary <- paste("fixed tausq with value =", nugget)
    kb.results$posterior$beta.samples <- as.matrix(beta)[vecpars.back.order,  ]
    beta <- NULL
    if(is.R()) gc(verbose=FALSE)
    if(beta.size == 1)
      kb.results$posterior$beta.samples <- as.vector(kb.results$posterior$
                                                     beta.samples)
    kb.results$posterior$sigmasq.samples <- sigmasq[vecpars.back.order]
    sigmasq <- NULL
    if(is.R()) gc(verbose=FALSE)
    kb.results$posterior$phi.samples <- phi.sam[vecpars.back.order,1]
    if(prior$nugget.rel.prior != "fixed")
      kb.results$posterior$tausq.samples <- phi.sam[vecpars.back.order,2]
    else
      kb.results$posterior$tausq.samples <- paste("fixed tausq with value =", nugget)
    phi.lev <- unique(phidist$phi[, 1])
    kb.results$posterior$phi.marginal <-
      data.frame(phi = phi.lev, expected = apply(phidist$probphi, 1, sum),
                 sampled = as.vector(table(factor(phi.sam[, 1],
                   levels = phi.lev)))/n.posterior)
    nug.lev <- unique(phidist$phi[, 2])
    if(prior$nugget.rel.prior != "fixed")
      kb.results$posterior$nugget.marginal <-
        data.frame(nugget = nug.lev, expected = apply(phidist$probphi, 2, sum),
                   sampled = as.vector(table(factor(phi.sam[, 2],
                     levels = nug.lev)))/n.posterior)
    else
      kb.results$posterior$nugget.marginal <- paste("fixed tausq with value =", nugget)
    ##
######################### PART 3.3 ##############################
    ## Predictive distribution: sampling and computation
    ##
    if(all(locations != "no")) {
      if(messages.screen)
        cat("krige.bayes: prediction at locations provided\n")
      if(output$mean.estimator != FALSE | !is.null(output$probability.estimator) |
         !is.null(output$quantile.estimator))
        prediction.samples <- TRUE     
      message.prediction <- character()
      ni <- dim(trend.l)[1]
      if(is.null(n.predictive)) {
        include.it <- FALSE
        n.predictive <- n.posterior
        phi.sam <- phidist$phi[ind,  ]
        message.prediction <- c("krige.bayes:", message.prediction, "phi/tausq.rel samples for the predictive are same as for the posterior"
                                )
        if(messages.screen)
          cat("krige.bayes:", message.prediction, "\n")
      }
      else {
        include.it <- TRUE
        ind <- sample((1:(dim(phidist$phi)[1])), n.predictive,
                      replace = TRUE, prob = as.vector(phidist$probphi))
        ind.unique <- sort(unique(ind))
        ind.length <- length(ind.unique)
        ind.table <- table(ind)
        phi.unique <- phidist$phi[ind.unique,  ]
        message.prediction <- c("krige.bayes:", message.prediction, 
                                "phi/tausq.rel samples for the predictive are NOT the same as for the posterior ")
        if(messages.screen) {
          cat("krige.bayes:", message.prediction, "\n")
          cat("krige.bayes: samples and their frequencies from the distribution of  phi and tau.rel when drawing from the predictive distribution\n")
          print(rbind(phi = phi.unique[, 1], nugget.rel
                      = phi.unique[, 2], frequency = ind.table))
        }
        phi.sam <- phidist$phi[ind,  ]
        vecpars.back.order <- order(ind)
      }
###      d0mat <- apply(locations, 1, d0.krige)
      d0mat <- as.double(rep(0, ni*n))
      .C("loccoords",
         as.double(as.vector(locations[,1])),
         as.double(as.vector(locations[,2])),
         as.double(as.vector(coords[,1])),
         as.double(as.vector(coords[,2])),
         as.integer(ni),
         as.integer(n),
         d0mat, DUP=FALSE)
      attr(d0mat, "dim") <- c(n, ni)
      loc.coincide <- apply(d0mat, 2, function(x){any(x < 1e-10)})
      if(any(loc.coincide))
        loc.coincide <- (1:ni)[loc.coincide]
      else
        loc.coincide <- NULL
      if(!is.null(loc.coincide)){
        temp.f <- function(x, data){return(data[x < 1e-10])}
        data.coincide <- apply(d0mat[,loc.coincide, drop=FALSE],2,temp.f, data=data)
      }
      else
        data.coincide <- NULL
      if(is.R()) gc(verbose=FALSE)
      ##
      ## 3.3.1 Estimating the moments
      ##
      if(moments) {
        krige.bayes.aux10 <- function(phinug){
          counter <- get(".tempM.krige.bayes", pos=1)
          if(messages.screen)          
          krige.bayes.messages(moments = TRUE, n.disc = n.disc,
                                 .temp.ap = counter, ind.length=ind.length)
          phinug <- as.vector(phinug)
          phi.ind <- order(phi.val)[round(100000000. * phi.val) ==
                                    round(100000000. * phinug[1])]
          nug.ind <- order(nugget.rel.discrete)[round(100000000. * nugget.rel.discrete) ==
                                            round(100000000. * phinug[2])]
          v0 <- cov.spatial(obj = d0mat, cov.model = cov.model, kappa
                            = kappa, cov.pars = c(1, phinug[1]))
          tb <- as.double(rep(0, ni*beta.size))
          tb <- .C("bilinearform_XAY",
                   as.double(as.vector(inv.lower[phi.ind, nug.ind,])),
                   as.double(as.vector(inv.diag[phi.ind, nug.ind,])),
                   as.double(as.vector(v0)),
                   as.double(as.vector(trend.data)),
                   as.integer(ni),
                   as.integer(beta.size),
                   as.integer(n),
                   res=tb)$res
          attr(tb, "dim") <- c(ni, beta.size)
          tb <- trend.l - tb
          tv0ivdata <- as.double(rep(0,ni))
          tv0ivdata <- .C("bilinearform_XAY",
                          as.double(as.vector(inv.lower[phi.ind, nug.ind,])),
                          as.double(as.vector(inv.diag[phi.ind, nug.ind,])),
                          as.double(as.vector(v0)),
                          as.double(data),
                          as.integer(ni),
                          as.integer(1),
                          as.integer(n),
                          res = tv0ivdata)$res
          tmean <- tv0ivdata + tb %*% as.vector(phidist$
                                                beta[phi.ind, nug.ind,  ])
          tv0ivdata <- NULL
          if(is.R()) gc(verbose=FALSE)
          if(((round(1e12 * phinug[2]) == 0)) & (!is.null(loc.coincide)))
            tmean[loc.coincide] <- data.coincide
          tv0ivv0 <- as.double(rep(0,ni))
          tv0ivv0 <- .C("diag_quadraticform_XAX",
                        as.double(as.vector(inv.lower[phi.ind, nug.ind,])),
                        as.double(as.vector(inv.diag[phi.ind, nug.ind,])),
                        as.double(as.vector(v0)),
                        as.integer(ni),
                        as.integer(n),
                        res = tv0ivv0)$res
          v0 <- NULL
          if(is.R()) gc(verbose=FALSE)
          s2i <- phidist$s2[phi.ind, nug.ind]        
          vbetai <- matrix(as.vector(phidist$vbeta.vector[phi.ind, nug.ind,  ]),
                           ncol = beta.size, nrow = beta.size)
          if(beta.size == 1)
            tbivbb <- ((as.vector(tb))^2) * vbetai
          else{
            tbivbb <- as.double(rep(0,ni))
            tbivbb <- .C("diag_quadraticform_XAX",
                         as.double(vbetai[lower.tri(vbetai)]),
                         as.double(diag(vbetai)),
                         as.double(as.vector(t(tb))),
                         as.integer(ni),
                         as.integer(beta.size),
                         res = tbivbb)$res          
          }
          if(output$signal)
            tvar <- s2i * (1 - tv0ivv0 + tbivbb)
          else tvar <- s2i * ((1 + phinug[2]) - tv0ivv0 + tbivbb)
          tb  <- tbivbb <- tv0ivv0 <- NULL
          if(is.R()) gc(verbose=FALSE)
          if(((round(1e12 * phinug[2]) == 0) | output$signal) & (!is.null(loc.coincide)))
            tvar[loc.coincide] <- 0
          tvar[tvar < 1e-16] <- 0
          ## take care here, re-using object!
          tvar <- (df.model/(df.model - 2)) * tvar
          tvar <- tvar + (tmean)^2
          ##  here tvar is expec.y0.2 !!!
          assign(".tempM.krige.bayes", (.tempM.krige.bayes + 1), pos=1)
          return(cbind(tmean, tvar))
        }
        if(messages.screen)
          cat("krige.bayes: computing moments of the predictive distributions\n")
        n.disc <- dim(phidist$phi)[1]
        assign(".tempM.krige.bayes", 1, pos=1)
        temp.res <- apply(phidist$phi, 1, krige.bayes.aux10)
        rm(".tempM.krige.bayes", pos=1)
        temp.res <- temp.res %*% as.vector(phidist$probphi)
        kb.results$predictive$moments <-
          data.frame(expect.y0 = as.vector(temp.res[1:ni]),
                     expect.y0.2 = as.vector(temp.res[(ni + 1):(2 * ni)]))
        temp.res <- NULL
        if(is.R()) gc(verbose=FALSE)
        kb.results$predictive$moments$var.y0 <-
          kb.results$predictive$moments$expect.y0.2 -
           ((kb.results$predictive$moments$expect.y0)^2)
        if(lambda == 0) {
          temp <- kb.results$predictive$moments$expect.y0
          kb.results$predictive$moments$expect.y0 <-
            exp(temp + 0.5 * (kb.results$predictive$moments$var.y0))
          kb.results$predictive$moments$var.y0 <-
            (exp(2 * temp + kb.results$predictive$moments$var.y0)) *
              (exp(kb.results$predictive$moments$var.y0) - 1)
          temp <- NULL
          if(is.R()) gc(verbose=FALSE)
          kb.results$predictive$moments$expect.y0.2 <-
            kb.results$predictive$moments$var.y0 +
              (kb.results$predictive$moments$expect.y0^2)
        }
      }
      ##
      ## 3.3.2 Sampling from the predictive
      ##
      if(output$simulations.predictive){
        names(ind.table) <- NULL
        krige.bayes.aux20 <- function(phinug){
          counter <- get(".tempS.krige.bayes", pos=1)
          if(messages.screen)
            krige.bayes.messages(moments = FALSE, n.disc = n.disc,
                                 .temp.ap = counter, ind.length=ind.length)
          phinug <- as.vector(phinug)
          phi.ind <- order(phi.val)[round(100000000. * phi.val) ==
                                    round(100000000. * phinug[1])]
          nug.ind <- order(nugget.rel.discrete)[round(100000000. * nugget.rel.discrete) ==
                                            round(100000000. * phinug[2])]
          v0 <- cov.spatial(obj = d0mat, cov.model = cov.model, kappa
                            = kappa, cov.pars = c(1, phinug[1]))
          tb <- as.double(rep(0, ni*beta.size))
          tb <- .C("bilinearform_XAY",
                   as.double(as.vector(inv.lower[phi.ind, nug.ind,])),
                   as.double(as.vector(inv.diag[phi.ind, nug.ind,])),
                   as.double(as.vector(v0)),
                   as.double(as.vector(trend.data)),
                   as.integer(ni),
                   as.integer(beta.size),
                   as.integer(n),
                   res=tb)$res
          attr(tb, "dim") <- c(ni, beta.size)
          tb <- trend.l - tb
          tv0ivdata <- as.double(rep(0,ni))
          tv0ivdata <- .C("bilinearform_XAY",
                          as.double(as.vector(inv.lower[phi.ind, nug.ind,])),
                          as.double(as.vector(inv.diag[phi.ind, nug.ind,])),
                          as.double(as.vector(v0)),
                          as.double(data),
                          as.integer(ni),
                          as.integer(1),
                          as.integer(n),
                          res = tv0ivdata)$res
          tmean <- tv0ivdata + tb %*% as.vector(phidist$
                                                beta[phi.ind, nug.ind,  ])
          tv0ivdata <- NULL
          if(is.R()) gc(verbose=FALSE)
          if(((round(1e12 * phinug[2]) == 0)) & (!is.null(loc.coincide)))
            tmean[loc.coincide] <- data.coincide
          s2i <- phidist$s2[phi.ind, nug.ind]        
          vbetai <- matrix(as.vector(phidist$vbeta.vector[phi.ind, nug.ind,  ]),
                           ncol = beta.size, nrow = beta.size)
          if(((round(1e12 * phinug[2]) == 0) | output$signal) & (!is.null(loc.coincide))){
            v0 <- v0[,-(loc.coincide)]
            nloc <- ni - length(loc.coincide)
            tmean.coincide <- tmean[loc.coincide]
            tmean <- tmean[-(loc.coincide)]
            tb <- tb[-(loc.coincide),]
          }
          else nloc <- ni
          Nsims <- ind.table[.tempS.krige.bayes]
          normalsc <- rnorm(nloc*Nsims)
          chisc <- rchisq(Nsims, df=df.model)
          sqglchi <- sqrt(df.model/chisc)
          if (output$signal) Dval <- 1.0 else Dval <-  1.0 + phinug[2]
          if(beta.size == 1){
            Blower <- 0
            Bdiag <- vbetai
          }
          else{
            Blower <- vbetai[lower.tri(vbetai)]
            Bdiag <- diag(vbetai)
          }
          R0 <- as.double(rep(0.0, (nloc*(nloc+1))/2))
          if(cov.model.number > 10){
            if(((round(1e12 * phinug[2]) == 0) | output$signal) & (!is.null(loc.coincide))){
              .C("distdiag",
                 as.double(locations[-(loc.coincide),1]),
                 as.double(locations[-(loc.coincide),2]),
                 as.integer(nloc),
                 R0, DUP = FALSE)
            }
            else
              .C("distdiag",
                 as.double(locations[,1]),
                 as.double(locations[,2]),
                 as.integer(ni),
                 R0, DUP = FALSE)
            R0 <- cov.spatial(R0, cov.pars=c(1, phinug[1]), cov.model=cov.model, kappa=kappa)
          }
          else{
            if(((round(1e12 * phinug[2]) == 0) | output$signal) & (!is.null(loc.coincide))){
              .C("cor_diag",
                 as.double(locations[-(loc.coincide),1]),
                 as.double(locations[-(loc.coincide),2]),
                 as.integer(nloc),
                 as.integer(cov.model.number),
                 as.double(phinug[1]),
                 as.double(kappa),
                 R0, DUP = FALSE)
            }
            else
              .C("cor_diag",
                 as.double(locations[,1]),
                 as.double(locations[,2]),
                 as.integer(ni),
                 as.integer(cov.model.number),
                 as.double(phinug[1]),
                 as.double(kappa),
                 R0, DUP = FALSE)
          }  
          normalsc <- .C("kb_sim",
                         as.double(tmean),
                         out = as.double(normalsc),
                         as.double(as.vector(inv.lower[phi.ind, nug.ind,])),
                         as.double(as.vector(inv.diag[phi.ind, nug.ind,])),
                         as.double(as.vector(v0)),
                         as.integer(nloc),
                         as.integer(n),
                         as.double(Dval),
                         as.integer(Nsims),
                         as.double(sqglchi),                      
                         as.double(s2i),                      
                         as.double(Blower),
                         as.double(Bdiag),
                         as.double(as.vector(t(tb))),
                         as.integer(beta.size),
                         as.double(R0))$out
          attr(normalsc, "dim") <- c(nloc, Nsims)
          v0 <- R0 <- tb <- NULL
          if(is.R()) gc(verbose=FALSE)
          ##
          assign(".tempS.krige.bayes", (.tempS.krige.bayes + 1), pos=1)
          if(((round(1e12 * phinug[2]) == 0) | output$signal) & (!is.null(loc.coincide))){
            result <- matrix(0, nrow=ni, ncol=Nsims)
            result[-(loc.coincide),] <- normalsc
            result[loc.coincide,] <- rep(tmean.coincide, Nsims)
            return(result)
          }
          else
            return(normalsc)
        }
        assign(".tempS.krige.bayes", 1, pos=1)
        kb.results$predictive$simulations <-
          matrix(unlist(apply(phi.unique, 1, krige.bayes.aux20)),ncol=n.predictive)
        remove("inv.lower", envir = sys.frame(nframe.del))
        remove("inv.diag", envir = sys.frame(nframe.del))
        remove(".tempS.krige.bayes", pos=1)
        if(is.R()) gc(verbose=FALSE)
        if(messages.screen)
          cat("krige.bayes: preparing output of predictive distribution\n")
        ##
        ## Back transforming
        ##
        if(lambda != 1) {
          cat("krige.bayes: Data transformation (Box-Cox) performed. Results returned in the original scale\n"
              )
          if(lambda == 0)
            kb.results$predictive$simulations <-
              exp(kb.results$predictive$simulations)
          else {
            if(lambda > 0)
              kb.results$predictive$simulations[kb.results$predictive$simulations < (-1/lambda)] <- -1/lambda
            if(lambda < 0)
              kb.results$predictive$simulations[kb.results$predictive$simulations > (-1/lambda)] <- -1/lambda
            kb.results$predictive$simulations <-
              ((kb.results$predictive$simulations * lambda) + 1)^(1/lambda)
          }
        }
        ##
        ## 3.3.3 mean estimators
        ##
        if(output$mean.estimator) {
          kb.results$predictive$mean.simulations <- as.vector(apply(kb.results$predictive$simulations, 1, mean))
          kb.results$predictive$variance.simulations <- as.vector(apply(kb.results$predictive$simulations, 1, var))
          message.prediction <- c("krige.bayes:", message.prediction, "mean at each location in $predictive$mean and predicted variances in $predictive$variances")
        }
        ##
        ## 3.3.4 quantile estimators
        ##
        if(!is.null(output$quantile.estimator)) {
          kb.results$predictive$quantiles <-
            apply(kb.results$predictive$simulations, 1, quantile, probs
                  = output$quantile.estimator)
          if(length(output$quantile.estimator) > 1) {
            kb.results$predictive$quantiles <- as.data.frame(t(kb.results$predictive$quantiles))
            qname <- rep(0, length(output$quantile.estimator))
            for(i in 1:length(output$quantile.estimator))
              qname[i] <- paste("q", 100 * output$quantile.estimator[
                                                              i], sep = "")
            names(kb.results$predictive$quantiles) <- qname
          }
          else {
            kb.results$predictive$quantiles <- as.vector(kb.results$predictive$
                                                         quantiles)
          }
          message.prediction <- c("krige.bayes:", message.prediction, 
                                  "Predicted quantile(s) at each location returned in $predictive$quantiles")
        }
        ##
        ## 3.3.5 probability estimators
        ##
        if(!is.null(output$probability.estimator)) {
          kb.results$predictive$probability <-
            apply(kb.results$predictive$simulations, 1, krige.bayes.aux2, cutoff = output$probability.estimator)
          if(length(output$probability.estimator) > 1){
            kb.results$predictive$probability <- as.data.frame(t(kb.results$predictive$probability))
          pname <- rep(0, length(output$probability.estimator))
          for(i in 1:length(output$probability.estimator))
            pname[i] <- paste("cutoff", output$probability.estimator[i], sep = "")
            names(kb.results$predictive$probability) <- pname
          }
          else
          kb.results$predictive$probability <- as.vector(kb.results$predictive$
                                                         probability)  
          message.prediction <- c("krige.bayes:", message.prediction,
                                  "Estimated probabilities of being less than the provided cutoff(s), at each location, returned in $predictive$probability")
        }
        ##
        ## samples from  predictive
        ##
        if(output$keep.simulations)
          kb.results$predictive$simulations <-
            kb.results$predictive$simulations[, vecpars.back.order]
        else kb.results$predictive$simulations <- NULL
        if(is.R()) gc(verbose=FALSE)
        if(include.it){
          phi.lev <- unique(phidist$phi[, 1])
          kb.results$predictive$phi.marginal <-
            data.frame(phi = phi.lev, expected = apply(phidist$probphi, 1, sum),
                       sampled = as.vector(table(factor(phi.sam[, 1],
                         levels = phi.lev)))/n.predictive)
          nug.lev <- unique(phidist$phi[, 2])
          if(prior$nugget.rel.prior != "fixed")
            data.frame(nugget = nug.lev, expected = apply(phidist$probphi, 2, sum),
                       sampled = as.vector(table(factor(phi.sam[, 2],
                         levels = nug.lev)))/n.predictive)
          else
            kb.results$predictive$nugget.marginal <- paste("fixed tausq with value =", nugget)
          kb.results$predictive$nugget.marginal <-
            data.frame(nugget = nug.lev,
                       expected = apply(phidist$probphi, 2, sum),
                       sampled = as.vector(table(factor(phi.sam[, 2],
                         levels = nug.lev)))/n.predictive)
        }
      }
      kb.results$predictive$type.prediction <-
        "Spatial prediction performed taking into account uncertainty in trend (mean), sill and range parameters"
      kb.results$message.prediction <- message.prediction
    }
    else {
      kb.results$predictive <- "no locations to perform prediction were provided"
      kb.results$message.prediction <- 
        "Only Bayesian estimation of model parameters were computed"
      if(messages.screen)
        print(kb.results$message.prediction)
    }
  }
  if(all(nugget != 0) & prior$nugget.rel.prior == "fixed")
    kb.results$nugget.fixed <- nugget
  kb.results$.Random.seed <- seed
#  if(info.for.prediction == TRUE & prior$range.prior != "fixed")
#    kb.results$info.for.prediction <-
#      list(coords = coords, cov.model = 
#           cov.model, kappa = kappa, trend.d = trend.d,
#           data = data, beta.size = beta.size, n = n,
#           phidist = phidist, phi.val = phi.val, nugget = 
#           nugget, distribution = distribution, 
#           n.posterior = n.posterior, ind.length = 
#           ind.length, vecpars.back.order = 
#           vecpars.back.order, phi.unique = phi.unique,
#           ind.table = ind.table, df.model = df.model, output$mean.estimator
#           = output$mean.estimator, output$quantile.estimator = 
#           output$quantile.estimator, output$probability.estimator = 
#           output$probability.estimator, ind = ind, lambda = 
#           lambda, moments = moments)
  kb.results$max.dist <- data.dist.max
  kb.results$call <- call.fc
  class(kb.results) <- c("krige.bayes", "kriging")
  if(messages.screen)
    cat("krige.bayes: done!\n")
  return(kb.results)
}

"krige.bayes.aux2" <- 
function(x, cutoff)
{
	# auxiliary function to perform calculation for the function krige.bayes
	ncut <- length(cutoff)
	lx <- length(x)
	if(ncut > 1) {
		result <- rep(0, ncut)
		for(i in 1:ncut)
			result[i] <- sum(x <= cutoff[i])/lx
	}
	else result <- sum(x <= cutoff)/lx
	return(result)
      }

"krige.bayes.aux3" <- 
  ##
  ## This function produces a sample from  a multivariate normal distribution 
  ## mean is 0 and cov.values is a vector of length beta.size^2
  function(cov.values, beta.size)
{
                                        #  dm <- length(mean)
                                        #  dc <- dim(cov.values)[1]
                                        #  if(dm != dc)
                                        #    stop("mean and cov.values must have compatible dimensions")
  cov.values <- matrix(cov.values, ncol = beta.size)
  cov.svd <- svd(cov.values)
  cov.decomp <- cov.svd$u %*% (t(cov.svd$u) * sqrt(cov.svd$d))
  zsim <- as.vector(cov.decomp %*% rnorm(beta.size))
  return(zsim)
}

"lines.krige.bayes" <- 
  function(obj, max.dist,
           summary.posterior = c("mode", "median", "mean"), ...)
{
  my.l <- list()
  if(missing(max.dist)){
    my.l$max.dist <- obj$max.dist
    if (is.null(my.l$max.dist) | !is.numeric(my.l$max.dist)) 
      stop("numerical argument max.dist needed for this object")
  }
  else my.l$max.dist <- max.dist
  spost <- match.arg(summary.posterior)
  if(is.null(obj$call$cov.model))
    my.l$cov.model <- "exponential"
  else {
    my.l$cov.model <- obj$call$cov.model
    if(obj$call$cov.model == "matern" | obj$call$cov.model == "powered.exponential" | obj$
       call$cov.model == "cauchy" | obj$call$cov.model == "gneiting-matern")
      my.l$kappa <- obj$call$kappa
    else my.l$kappa <- NULL
  }
  if(spost == "mode")
    spost1 <- "mode.cond"
  else spost1 <- spost
  my.l$cov.pars <- c(obj$posterior$sigmasq.summary[spost1], obj$posterior$phi.summary[spost])
  names(my.l$cov.pars) <- NULL
  if(is.numeric(obj$posterior$tausq.summary))
    nugget <- obj$posterior$tausq.summary[spost] * my.l$cov.pars[1]
  else nugget <- 0
  names(nugget) <- NULL
  my.l$sill.total <- nugget + my.l$cov.pars[1]
  gamma.f <- function(x, my.l)
    {
      return(my.l$sill.total -
             cov.spatial(x, cov.model = my.l$cov.model, kappa = my.l$kappa,
                         cov.pars = my.l$cov.pars))
    }
  curve(gamma.f(x,my.l=my.l), from = 0, to = my.l$max.dist, add=TRUE, ...)
  return(invisible())
}

"prepare.graph.krige.bayes" <-
  function (obj, locations, borders, 
            values.to.plot, number.col) 
{
  if (!is.numeric(values.to.plot)){
    switch(values.to.plot,
           moments.mean =
           {
             values <- obj$predictive$moments$expect.y0
             cat("image.krige.bayes: plotting map the mean of the predictive distribution\n")
           },
           moments.variance = {
             values <- obj$predictive$moments$var.y0
             cat("plotting map the variance of the predictive distribution\n")
           },
           mean.simulations=
           {
             values <- obj$predictive$mean.simulations
             cat("plotting map the mean of the simulations from the predictive distribution\n")
           },
           variance.simulations =
           {
             values <- obj$predictive$variance.simulations
             cat("plotting map the variance of the predictive distribution\n")
           },
           quantile =
           {
             if(!is.vector(obj$predictive$quantiles))
               if(is.null(number.col))
                 stop("argument number.col must be provided")
               else
                 values <- obj$predictive$quantiles[,number.col]
             else
               values <- obj$predictive$quantiles
             cat("plotting map a quantile of the predictive distribution\n")
           },
           probability =
           {
             if(!is.vector(obj$predictive$probability))
               if(is.null(number.col))
                 stop("argument number.col must be provided")
               else
                 values <- obj$predictive$probability[,number.col]
             else
               values <- obj$predictive$probability
             cat("plotting map a simulation of the predictive distribution\n")
           },
           simulation =
           {
             values <- obj$predictive$simulations[,number.col]
             cat("plotting map the variance of the predictive distribution\n")
           },
           stop("wrong specification for values to plot")
           )
  }
  else values <- values.to.plot
  remove("values.to.plot")
  if(!is.null(borders)){
    borders <- as.matrix(as.data.frame(borders))
    if(is.R())
      require(splancs)
    inout.vec <- as.vector(inout(pts = locations, poly = borders))
    if(sum(inout.vec) != length(values))
      stop("image.krige.bayes: length of the argument values is incompatible with number of elements inside the borders.")
    temp <- rep(NA, nrow(locations))
    temp[inout.vec == T] <- values
    values <- temp
    remove("temp")
  }
  locations <- locations[order(locations[, 2], locations[,1]), ]
  x <- as.numeric(levels(as.factor(locations[, 1])))
  nx <- length(x)
  y <- as.numeric(levels(as.factor(locations[, 2])))
  ny <- length(y)
  coords.lims <- set.coords.lims(coords=locations)
  return(list(x=x, y=y, values = matrix(values,ncol=ny), coords.lims=coords.lims))
}

"image.krige.bayes" <-
  function (obj, locations, borders, 
            values.to.plot = c("moments.mean", "moments.variance",
              "mean.simulations", "variance.simulations",
              "quantiles", "probability", "simulation"),
            number.col, coords.data, ...)
{
  if(all(is.character(values.to.plot)))
    values.to.plot <- match.arg(values.to.plot)
  if(missing(borders)) borders <- NULL
  if(missing(number.col)) number.col <- NULL
  if(missing(coords.data)) coords.data <- NULL
  locations <- prepare.graph.krige.bayes(obj=obj, locations=locations,
                                         borders=borders,
                                         values.to.plot=values.to.plot,
                                         number.col = number.col)
  pty.prev <- par()$pty
  par(pty = "s")
  image(locations$x, locations$y, locations$values,
        xlim= locations$coords.lims[,1], ylim=locations$coords.lims[,2],...)
  if(!is.null(coords.data))
    points(coords.data)
  if(!is.null(borders))
    lines(borders, lwd=2)
  par(pty=pty.prev)
  return(invisible())
}

"persp.krige.bayes" <-
  function (obj, locations, borders, 
            values.to.plot = c("moments.mean", "moments.variance",
              "mean.simulations", "variance.simulations",
              "quantiles", "probability", "simulation"), number.col, ...) 
{
  values.to.plot <- match.arg(values.to.plot)
  if(missing(borders)) borders <- NULL
  if(missing(number.col)) number.col <- NULL
  locations <- prepare.graph.krige.bayes(obj=obj, locations=locations,
                                         borders=borders,
                                         values.to.plot=values.to.plot,
                                         number.col = number.col)
  persp(locations$x, locations$y, locations$values, ...)
  return(invisible())
}

"model.control" <-
  function(trend.d = "cte", trend.l = "cte",
           cov.model = "matern",
           kappa=0.5, aniso.pars=NULL, lambda=1) 
{
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  return(list(trend.d = trend.d, trend.l = trend.l,
              cov.model = cov.model,
              kappa=kappa, aniso.pars=aniso.pars, lambda=lambda))
}

"prior.control" <-
  function(beta.prior = c("flat", "normal", "fixed"),
           beta = NULL, beta.var = NULL,
           sill.prior = c("reciprocal", "fixed"), sill = NULL, 
           range.prior = c("uniform", "exponential", "fixed",
             "squared.reciprocal","reciprocal"),
           exponential.prior.par = 1,
           range = NULL, range.discrete = NULL, 
           nugget.rel.prior = c("fixed", "uniform"), nugget.fixed = 0,
           nugget.rel.discrete = NULL)
{
  beta.prior <- match.arg(beta.prior)
  sill.prior <- match.arg(sill.prior)
  range.prior <- match.arg(range.prior)
  nugget.rel.prior <- match.arg(nugget.rel.prior)
  return(list(beta.prior = beta.prior, beta = beta, beta.var = beta.var,
              sill.prior = sill.prior, sill = sill, 
              range.prior = range.prior,
              exponential.prior.par = exponential.prior.par,
              range = range, range.discrete = range.discrete, 
              nugget.rel.prior = nugget.rel.prior,
              nugget.fixed = nugget.fixed,
              nugget.rel.discrete = nugget.rel.discrete))
}

"output.control" <-
  function(n.posterior = 1000, n.predictive = NULL,
           simulations.predictive = TRUE, keep.simulations = TRUE,
           mean.estimator = TRUE, quantile.estimator = NULL,
           probability.estimator = NULL, messages.screen = TRUE,
           signal = TRUE, moments = TRUE)
{
  return(list(n.posterior = n.posterior, n.predictive = n.predictive,
              moments = moments,
              simulations.predictive = simulations.predictive,
              keep.simulations = keep.simulations,
              mean.estimator = mean.estimator,
              quantile.estimator = quantile.estimator,
              probability.estimator = probability.estimator,
              signal = signal, messages.screen = messages.screen))
}

"krige.bayes.messages" <- 
function(moments, n.disc, .temp.ap, ind.length)
{  
  if(moments){
    if(n.disc <= 50)
      cat(paste("computing moments: point",
                .temp.ap, "out of", n.disc, "\n"))
    if(n.disc > 50 & n.disc <= 500)
      if(.temp.ap %% 10 == 1){
        cat(paste("computing moments: point",
                  .temp.ap, "out of", n.disc))
        if(.temp.ap == 1) cat("                   (counting for each 10)\n")
        else cat("\n")
      }
    if(n.disc > 500)
      if(.temp.ap %% 100 == 1){
        cat(paste("computing moments: point",
                  .temp.ap, "out of", n.disc))
        if(.temp.ap == 1) cat("                   (counting for each 100)\n")
        else cat("\n")
      }
  }
  else{
    if(ind.length <= 50)
      cat(paste("simulating from the predictive for the parameter set", 
                .temp.ap, "out of", ind.length, "\n"))
    if(ind.length > 50 & ind.length <= 500)
      if(.temp.ap %% 10 == 1){
        cat(paste("simulating from the predictive for the parameter set",
                  .temp.ap, "out of", 
                  ind.length))
        if(.temp.ap == 1) cat("                   (counting for each 10)\n")
        else cat("\n")
      }
    if(ind.length > 500)
      if(.temp.ap %% 100 == 1){
        cat(paste("simulating from the predictive for the parameter set",
                  .temp.ap, "out of", 
                  ind.length))
        if(.temp.ap == 1) cat("                   (counting for each 100)\n")
        else cat("\n")
      }
  }
}

"geoRdefunct" <-
  function()
  {
    cat("\n")
    cat("The following functions are no longer used in geoR:")
    cat("---------------------------------------------------")
    cat("\nolsfit: use variofit() instead")
    cat("\nwlsfit: use variofit() instead")
    cat("\nlikfit.old: use likfit() instead")
    cat("\n")
  }
    
"ksline" <-
  function (geodata, coords=geodata$coords, data=geodata$data, locations,
            cov.model = "matern",
            cov.pars = stop("covariance parameters (sigmasq and phi) needed"), 
            kappa = 0.5, nugget = 0, micro.scale = 0,
            lambda = 1, m0 = "ok", nwin = "full", 
            n.samples.backtransform = 500, 
            trend = 1, d = 2, ktedata = NULL, ktelocations = NULL,
            aniso.pars = NULL,  signal = FALSE,  dist.epsilon = 1e-10,
            messages.screen = TRUE) 
{
  require(mva)
  call.fc <- match.call()
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  if(lambda != 1) {
    if(messages.screen)
      cat("ksline: Data transformation (Box-Cox) performed.\n")
    if(lambda == 0)
      data <- log(data)
    else data <- ((data^lambda) - 1)/lambda
  }
  coords <- as.matrix(coords)
  locations <- as.matrix(locations)
  dimnames(coords) <- list(NULL, NULL)
  dimnames(locations) <- list(NULL, NULL)
  if (!is.null(ktedata) & !is.null(ktelocations) & m0 != "kte"){
    cat("ksline: external variable (covariate) provided. Kriging ste to KTE\n")
    m0 <- "kte"
  }
  ##
  ## anisotropy correction
  ##
  if(!is.null(aniso.pars)) {
    if(length(aniso.pars) != 2 | !is.numeric(aniso.pars))
      stop("anisotropy parameters must be provided as a numeric vector with two elements: the rotation angle (in radians) and the anisotropy ratio (a number greater than 1)")
    if(messages.screen)
      cat("ksline: anisotropy correction performed\n")
    coords.c <- coords.aniso(coords = coords, aniso.pars = aniso.pars)
    locations.c <- coords.aniso(coords = locations, aniso.pars = aniso.pars)
  }
  else {
    coords.c <- coords
    locations.c <- locations
  }
  ## 2. Preparing KTE matrices #####
  ##  
  if (m0 == "kte") {
    ktedata <- as.matrix(ktedata)
    ktelocations <- as.matrix(ktelocations)
    dimnames(ktedata) <- list(NULL, NULL)
    dimnames(ktelocations) <- list(NULL, NULL)
  }
  n <- length(data)
  ni <- length(locations[, 1])
  tausq <- nugget
  sigmasq <- cov.pars[1]
  phi <- cov.pars[2]
  if (nwin == "full") {
    est <- rep(0, ni)
    dif <- rep(0, ni)
    kvar <- rep(0, ni)
    sumw <- rep(0, ni)
    wofmean <- rep(0, ni)
    iv <- varcov.spatial(coords = coords.c, cov.model = cov.model, 
                         kappa = kappa, nugget = nugget, cov.pars = cov.pars, 
                         inv = TRUE, det = FALSE, func.inv = "cholesky")$inverse
    av <- mean(data)
    sd <- sqrt(var(data))
    one <- rep(1, n)
    tone <- t(one)
    toneiv <- crossprod(one, iv)
    den <- solve(toneiv %*% one)
    ml <- den %*% toneiv %*% data
    kmsd <- sqrt(den)
    means <- c(average = av, stdev = sd, kmean = ml, kmsd = kmsd)
    if (m0 != "kt") {
      mktlocations <- "Constant trend"
      beta <- ml
    }
    else {
      mktlocations <- rep(0, ni)
      if (m0 == "kt" & trend == 1) {
        if (d == 1) {
          xmat <- cbind(rep(1, n), coords[, 2])
          xmati <- cbind(rep(1, ni), locations[, 2])
        }
        else {
          xmat <- cbind(rep(1, n), coords[, 1], coords[, 2])
          xmati <- cbind(rep(1, ni), locations[, 1], locations[, 
                                                               2])
        }
        iviv <- solve(crossprod(xmat,iv) %*% xmat)
        txiv <- crossprod(xmat,iv)
        beta <- iviv %*% txiv %*% data
        mkt <- xmat %*% beta
      }
      if (m0 == "kt" & trend == 2) {
        if (d == 1) {
          xmat <- cbind(rep(1, n), coords[, 2], (coords[, 2])^2)
          xmati <- cbind(rep(1, ni), locations[, 2], (locations[, 
                                                                2])^2)
        }
        else {
          xmat <- cbind(rep(1, n), coords[, 1], coords[, 2], 
                        (coords[, 1])^2, (coords[, 2])^2, coords[, 1] * coords[, 
                                                                               2])
          xmati <- cbind(rep(1, ni), locations[, 1], locations[, 
                                                               2], (locations[, 1])^2, (locations[, 2])^2, locations[, 
                                                                                                                     1] * locations[, 2])
        }
        iviv <- solve(crossprod(xmat,iv) %*% xmat)
        txiv <- crossprod(xmat,iv)
        beta <- iviv %*% txiv %*% data
        mkt <- xmat %*% beta
      }
    }
    if (m0 != "kte") 
      mktelocations <- "No external trend"
    else {
      if (m0 == "kte") {
        mktelocations <- rep(0, ni)
        xmat <- cbind(rep(1, n), ktedata)
        xmati <- cbind(rep(1, ni), ktelocations)
        iviv <- solve(crossprod(xmat,iv) %*% xmat)
        txiv <- crossprod(xmat,iv)
        beta <- iviv %*% txiv %*% data
        mkte <- xmat %*% beta
      }
    }
    for (i in 1:ni) {
      if (messages.screen) {
        if (ni < 11) 
          cat(paste("ksline: kriging location: ", i, "out of", 
                    ni, "\n"))
        else {
          if (ni < 101 & (i%%10 == 1)) 
            cat(paste("ksline: kriging location: ", i, "out of", 
                      ni, "\n"))
          if (ni > 100 & i%%100 == 1) 
            cat(paste("ksline: kriging location: ", i, "out of", 
                      ni, "\n"))
          if (i == ni) 
            cat(paste("ksline: kriging location: ", i, "out of", 
                      ni, "\n"))
        }
      }
      coords0 <- cbind((coords.c[, 1] - locations.c[i, 1]), (coords.c[, 2] - locations.c[i, 
                                                                                 2]))
      dm0 <- sqrt(coords0[, 1]^2 + coords0[, 2]^2)
      v0 <- cov.spatial(obj = dm0, cov.model = cov.model, 
                        kappa = kappa, cov.pars = cov.pars)
      v0[dm0 < dist.epsilon] <- micro.scale + sigmasq
      tv0 <- t(v0)
      v0iv <- crossprod(v0, iv)
      v0ivv0 <- v0iv %*% v0
      skw <- crossprod(v0,iv)
      wofmean[i] <- 1 - sum(skw)
      ##
      ## 4.2.1 Simple kriging with known mean
      ##
      if (is.numeric(m0) == TRUE) {
        dif[i] <- skw %*% (data - m0)
        est[i] <- m0 + dif[i]
        if (signal == TRUE) 
          kvar[i] <- sigmasq - v0ivv0
        else kvar[i] <- tausq + sigmasq - v0ivv0
        sumw[i] <- sum(skw)
      }
      ##
      ## 4.2.2 Simple kriging with data average mean
      ##
      if (m0 == "av") {
        dif[i] <- skw %*% (data - av)
        est[i] <- av + dif[i]
        if (signal == TRUE) 
          kvar[i] <- sigmasq - v0ivv0
        else kvar[i] <- tausq + sigmasq - v0ivv0
        sumw[i] <- sum(((tone/n) + skw - ((skw %*% one %*% 
                                           tone)/n)))
      }
      ##
      ## 4.2.3 Ordinary kriging (or SK with G.L.S. mean)
      ##
      if(m0 == "ok") {
        dif[i] <- skw %*% (data - ml)
        est[i] <- ml + dif[i]
        redu <- as.vector(1 - toneiv %*% v0)
        if(signal == TRUE)
          kvar[i] <- sigmasq - v0ivv0 + (redu %*%
                                         den %*% redu)
        else kvar[i] <- tausq + sigmasq - v0ivv0 + (
                                                    redu %*% den %*% redu)
        sumw[i] <- sum((den %*% one + tv0 - v0iv %*% 
                        one %*% den %*% tone) %*% iv)
      }
      ##
      ## 4.2.4 Universal Kriging (or Kriging with trend model) 
      ##
      if(m0 == "kt") {
        dif[i] <- skw %*% (data - mkt)
        est[i] <- xmati[i,  ] %*% beta + dif[i]
        redu <- as.vector(xmati[i,  ]) - as.vector(
                                                   txiv %*% v0)
        if(signal == TRUE)
          kvar[i] <- sigmasq - v0ivv0 + (redu %*%
                                         iviv %*% redu)
        else kvar[i] <- tausq + sigmasq - v0ivv0 + (
                                                    redu %*% iviv %*% redu)
        sumw[i] <- sum(skw + xmati[i,  ] %*% iviv %*%
                       txiv - skw %*% xmat %*% iviv %*% txiv)
        mktlocations[i] <- xmati[i,  ] %*% beta
      }
      ##
      ## 4.2.5 Kriging with external trend 
      ##
      if(m0 == "kte") {
        dif[i] <- skw %*% (data - mkte)
        est[i] <- xmati[i,  ] %*% beta + dif[i]
        redu <- as.vector(xmati[i,  ]) - as.vector(
                                                   txiv %*% v0)
        if(signal == TRUE)
          kvar[i] <- sigmasq - v0ivv0 - (redu %*%
                                         iviv %*% redu)
        else kvar[i] <- tausq + sigmasq - v0ivv0 + (
                                                    redu %*% iviv %*% redu)
        sumw[i] <- sum(skw + xmati[i,  ] %*% iviv %*%
                       txiv - skw %*% xmat %*% iviv %*% txiv)
        mktelocations[i] <- xmati[i,  ] %*% beta
      }
      NULL
    }
    message <- "Kriging performed in global neighbourhood"
    if (messages.screen) 
      cat(paste(message,"\n"))
    results <- list(predict = est, krige.var = kvar, dif = dif, summary = means, 
                    ktrend = mktlocations, ktetrend = mktelocations, beta = beta, 
                    wofmean = wofmean)
  }
  else {
    nwin <- min(n, nwin)
    avwin <- rep(0, ni)
    sdwin <- rep(0, ni)
    mlwin <- rep(0, ni)
    kmsdwin <- rep(0, ni)
    estwin <- rep(0, ni)
    difwin <- rep(0, ni)
    kvarwin <- rep(0, ni)
    sumwwin <- rep(0, ni)
    wofmean <- rep(0, ni)
    if (m0 != "kt") 
      mkt <- "Constant position trend"
    else mkt <- rep(0, ni)
    if (m0 != "kte") 
      mkte <- "No external trend"
    else mkte <- rep(0, ni)
    if (m0 != "kt" & m0 != "kte") 
      betawin <- "No polynomial or external trend"
    if (m0 == "kt") {
      if (trend == 1) {
        if (d == 1) 
          xmati <- cbind(rep(1, ni), locations[, 2])
        else xmati <- cbind(rep(1, ni), locations[, 1], locations[, 
                                                                  2])
      }
      if (trend == 2) {
        if (d == 1) 
          xmati <- cbind(rep(1, ni), locations[, 2], locations[, 
                                                               2]^2)
        else xmati <- cbind(rep(1, ni), locations[, 1], locations[, 
                                                                  2], (locations[, 1])^2, (locations[, 2])^2, locations[, 1] * 
                            locations[, 2])
      }
      betawin <- matrix(0, nrow = (ncol(xmati) * ni), ncol = ncol(xmati))
    }
    if (m0 == "kte") {
      xmati <- cbind(rep(1, ni), ktelocations)
      if (is.vector(ktedata) == TRUE) 
        betawin <- matrix(0, nrow = (2 * ni), ncol = 2)
      else betawin <- matrix(0, nrow = ((ncol(ktedata) + 
                                         1) * ni), ncol = (ncol(ktedata) + 1))
    }
    for (i in 1:ni) {
      temp.win <- ksline.aux.1(coords = coords, coords.c = coords.c,
                               data = data, n = n,
                               locations = locations[i,  ],
                               locations.c = locations.c[i,  ],
                               cov.pars = cov.pars, nugget = nugget,
                               cov.model = cov.model, kappa = kappa, m0 = m0,
                               nwin = nwin, trend = trend, d = d, ktedata = 
                               ktedata, ktelocations = ktelocations,
                               micro.scale = micro.scale, 
                               location.number = i, xmati = xmati[i,  ],
                               mkte = NULL, mkt = NULL, betawin = NULL,
                               signal = signal, dist.epsilon = dist.epsilon)
      avwin[i] <- temp.win$avwin
      sdwin[i] <- temp.win$sdwin
      mlwin[i] <- temp.win$mlwin
      kmsdwin[i] <- temp.win$kmsdwin
      estwin[i] <- temp.win$estwin
      difwin[i] <- temp.win$difwin
      kvarwin[i] <- temp.win$kvarwin
      sumwwin[i] <- temp.win$sumwwin
      wofmean[i] <- temp.win$wofmean
      if (m0 == "kt") 
        mkt[i] <- temp.win$mkt
      if (m0 == "kte") 
        mkte[i] <- temp.win$mkte
      if (m0 == "kt" | m0 == "kte") 
        betawin[i, ] <- temp.win$betawin
      if (messages.screen) {
        if (ni < 11) 
          cat(paste("ksline: kriging location: ", i, "out of", 
                    ni, "\n"))
        else {
          if (ni < 101 & (i%%10 == 1)) 
            cat(paste("ksline: kriging location: ", i, "out of", 
                      ni, "\n"))
          if (ni > 100 & i%%100 == 1) 
            cat(paste("ksline: kriging location: ", i, "out of", 
                      ni, "\n"))
          if (i == ni) 
            cat(paste("ksline: kriging location: ", i, "out of", 
                      ni, "\n"))
        }
      }
    }
    message <- "kriging performed in moving neighbourhood"
    if (messages.screen) 
      cat(paste(message,"\n"))
    results <- list(predict = estwin, krige.var = kvarwin, dif = difwin, 
                    avtrend = avwin, sd = sdwin, oktrend = mlwin, oksd = kmsdwin, 
                    ktrend = mkt, ktetrend = mkte, beta = betawin, sumw = sumwwin, 
                    wofmean = wofmean)
  }  
  if(lambda != 1) {
    if(messages.screen)
      cat("Back-transforming the predictions according to the (Box-Cox) parameter lambda\n")
    if(lambda == 0) {
      predict.transf <- results$predict
      results$predict <- exp(predict.transf) - 0.5 * results$krige.var
      results$krige.var <- (exp(2 * predict.transf - results$krige.var)) * (exp(results$krige.var) - 1)
    }
    if(lambda > 0) {
      if(messages.screen)
        cat("Back-transformation done by sampling from the resulting (normal) predictive distribution\n")
      ap.warn <- options()$warn
      options(warn = -1)
      temp.data <- matrix(rnorm(ni * n.samples.backtransform,
                                mean = results$predict, sd = sqrt(results$krige.var)),
                          nrow = ni)
      options(warn = ap.warn)
      temp.data[(results$krige.var == 0),  ] <- results$predict[(results$krige.var == 0)]
      temp.data[temp.data < -1/lambda] <- -1/lambda     
      temp.data <- ((temp.data * lambda) + 1)^(1/lambda)
###      temp.data[is.na(temp.data)] <- Inf
      results$predict <- as.vector(apply(temp.data, 1, mean))
      results$krige.var <- as.vector(apply(temp.data, 1, var))
    }
    if(lambda < 0) {
      cat("Resulting distribution has no mean for lambda < 0 - back transformation not performed\n"
          )
    }
  }
  results$locations <- locations
  results$message <- message
  results$call <- call.fc
  class(results) <- c("kriging")
  return(invisible(results))
}

"ksline.aux.1" <-
  function (coords, coords.c, data, n, locations, locations.c, cov.pars,
            nugget, cov.model, kappa, 
            m0, nwin, trend, d, ktedata, ktelocations, mbased,
            micro.scale, location.number, 
            xmati, mkte, mkt, betawin, signal, dist.epsilon) 
{
  require(mva)
  i <- location.number
  sigmasq <- cov.pars[1]
  phi <- cov.pars[2]
  tausq <- nugget
  coords0 <- cbind((coords.c[, 1] - locations.c[1]), (coords.c[, 2] -
                                                      locations.c[2]))
  dm0 <- sqrt(coords0[, 1]^2 + coords0[, 2]^2)
  coordswin <- coords[order(dm0)[1:nwin],  ]
  coordswin.c <- coords.c[order(dm0)[1:nwin],  ]
  datawin <- data[order(dm0)[1:nwin]]
  ivwin <- varcov.spatial(coords = coordswin.c, cov.model = cov.model,
                          kappa = kappa, nugget = nugget, cov.pars = cov.pars, inv = TRUE,
                          det = FALSE, func.inv = "cholesky", only.decomp = FALSE)$inverse
  avwin <- mean(datawin)
  sdwin <- sqrt(var(datawin))
  onewin <- rep(1, nwin)
  toneivwin <- crossprod(onewin, ivwin)
  denwin <- solve(toneivwin %*% onewin)
  mlwin <- denwin %*% toneivwin %*% datawin
  kmsdwin <- sqrt(denwin)
  coords0win <- cbind((coordswin[, 1] - locations[1]), (coordswin[, 2] -
                                                        locations[2]))
  coords0win.c <- cbind((coordswin.c[, 1] - locations.c[1]), (coordswin.c[
                                                                          , 2] - locations.c[2]))
  dm0win <- sqrt(coords0win.c[, 1]^2 + coords0win.c[, 2]^2)
  v0win <- cov.spatial(obj = dm0win, cov.model = cov.model, kappa = kappa,
                       cov.pars = cov.pars)
  v0win[dm0win < dist.epsilon] <- micro.scale + sigmasq
  skwwin <- crossprod(v0win, ivwin)
  wofmean <- 1 - sum(skwwin)
  if(m0 == "kt" & trend == 1) {
    if(d == 1)
      xmatwin <- cbind(rep(1, nwin), coordswin[, 2])
    else xmatwin <- cbind(rep(1, nwin), coordswin[, 1], coordswin[
                                                                  , 2])
    txivwin <- crossprod(xmatwin, ivwin)
    ivivwin <- solve(txivwin %*% xmatwin)
    betawin <- ivivwin %*% txivwin %*% datawin
    mktwin <- xmatwin %*% betawin
    mkt <- xmati %*% betawin
  }
  if(m0 == "kt" & trend == 2) {
    if(d == 1)
      xmatwin <- cbind(rep(1, nwin), coordswin[, 2], (
                                                      coordswin[, 2])^2)
    else xmatwin <- cbind(rep(1, nwin), coordswin[, 1], (coordswin[
                                                                   , 1])^2, coordswin[, 2], (coordswin[, 2])^
                          2, coordswin[, 1] * coordswin[, 2])
    xmatwin.cent <- xmatwin
    xmatwin.cent[, 2] <- xmatwin.cent[, 2] - mean(xmatwin[, 2])
    xmatwin.cent[, 3] <- xmatwin.cent[, 3] - mean(xmatwin[, 3])
    ivivwin <- solve(crossprod(xmatwin.cent, ivwin) %*% 
                     xmatwin.cent)
    txivwin <- crossprod(xmatwin.cent, ivwin)
    betawin <- ivivwin %*% txivwin %*% datawin
    betawin <- mean(datawin) - crossprod(betawin, c(0, mean(xmatwin[
                                                                    , 2]), mean(xmatwin[, 3])))
    mktwin <- xmatwin %*% betawin
    mkt <- xmati %*% betawin
  }
  if(m0 == "kte") {
    if(is.vector(ktedata))
      ktedatawin <- ktedata[order(dm0)[1:nwin]]
    else ktedatawin <- ktedata[order(dm0)[1:nwin],  ]
    xmatwin <- cbind(rep(1, nwin), ktedatawin)
    ivivwin <- solve(crossprod(xmatwin, ivwin) %*% xmatwin)
    txivwin <- crossprod(xmatwin, ivwin)
    betawin <- ivivwin %*% txivwin %*% datawin
    mktewin <- xmatwin %*% betawin
    mkte <- xmati %*% betawin
  }
  ##
  ##  Simple kriging with known mean
  ##
  if(is.numeric(m0)) {
    difwin <- skwwin %*% (data - m0)
    estwin <- m0win + difwin
    if(signal)
      kvarwin <- sigmasq - crossprod(v0win, ivwin) %*% v0win
    else kvarwin <- tausq + sigmasq - crossprod(v0win, ivwin) %*%
      v0win
    sumwwin <- sum(skwwin)
  }
  ##
  ## 4.2.2 Simple kriging with data average mean
  ##
  if(m0 == "av") {
    difwin <- skwwin %*% (datawin - avwin)
    estwin <- avwin + difwin
    if(signal)
      kvarwin <- sigmasq - crossprod(v0win, ivwin) %*% v0win
    else kvarwin <- tausq + sigmasq - crossprod(v0win, ivwin) %*%
      v0win
    sumwwin <- sum(((t(onewin)/nwin) + skwwin - ((skwwin %*% onewin %*%
                                                  t(onewin))/n)))
  }
  ##
  ## Ordinary kriging (or SK with G.L.S. mean)
  ##
  if(m0 == "ok") {
    difwin <- skwwin %*% (datawin - mlwin)
    estwin <- mlwin + difwin
    redu <- as.vector(1 - toneivwin %*% v0win)
    if(signal)
      kvarwin <- sigmasq - v0win %*% ivwin %*% v0win + (
                                                        redu %*% denwin %*% redu)
    else kvarwin <- tausq + sigmasq - v0win %*% ivwin %*% v0win +
      (redu %*% denwin %*% redu)
    sumwwin <- sum((denwin %*% onewin + t(v0win) - crossprod(v0win,
                                                             ivwin) %*% onewin %*% denwin %*% t(onewin)) %*% ivwin)
  }
  ##
  ## Universal Kriging (or Kriging with trend model) 
  ##
  if(m0 == "kt") {
    difwin <- skwwin %*% (datawin - mktwin)
    estwin <- mkt + difwin
    xmati <- as.vector(xmati)
    redu <- as.vector(xmati) - as.vector(txivwin %*% v0win)
    if(signal)
      kvarwin <- sigmasq - (v0win %*% ivwin %*% v0win) + (redu %*% ivivwin %*% redu)
    else kvarwin <- tausq + sigmasq - (v0win %*% ivwin %*% v0win) + (redu %*% ivivwin %*% redu)
    sumwwin <- sum(skwwin + xmati %*% ivivwin %*% txivwin - skwwin %*%
                   xmatwin %*% ivivwin %*% txivwin)
  }
  ##
  ## Kriging with external trend 
  ##
  if(m0 == "kte") {
    difwin <- skwwin %*% (datawin - mktewin)
    estwin <- mkte + difwin
    xmati <- as.vector(xmati)
    redu <- as.vector(xmati) - as.vector(txivwin %*% v0win)
    if(signal)
      kvarwin <- sigmasq - (v0win %*% ivwin %*% v0win) + (redu %*% ivivwin %*% redu)
    else kvarwin <- tausq + sigmasq - (v0win %*% ivwin %*% v0win) + (redu %*% ivivwin %*% redu)
    sumwwin <- sum(skwwin + xmati %*% ivivwin %*% txivwin - skwwin %*%
                   xmatwin %*% ivivwin %*% txivwin)
  }
  ##
  ##
  ##  
  results <- list(avwin = avwin, sdwin = sdwin, mlwin = mlwin, kmsdwin = 
                  kmsdwin, wofmean = wofmean, betawin = betawin, mkt = mkt, mkte
                  = mkte, difwin = difwin, estwin = estwin, kvarwin = kvarwin,
                  sumwwin = sumwwin)
  return(results)
}

"krige.conv" <-
  function (geodata, coords=geodata$coords, data=geodata$data, locations,
            krige = krige.control(
              type.krige, beta = NULL, trend.d, trend.l,
              cov.model, cov.pars, kappa = 0.5, 
              nugget = 0, micro.scale = 0,
              dist.epsilon = 1e-10,
              aniso.pars = NULL, lambda = 1,
              signal = FALSE,
              n.samples.backtransform = 500, n.sim = 0),
            messages.screen = TRUE)
{
  call.fc <- match.call()
  ##
  ## reading input
  ##
  cov.model <- krige$cov.model
  kappa <- krige$kappa
  lambda <- krige$lambda
  ##
  beta <- krige$beta
  cov.pars <- krige$cov.pars
  nugget <- krige$nugget
  ##
  signal <- krige$signal
  n.sim <- krige$n.sim
  n.samples.backtransform <- krige$n.samples.backtransform
  micro.scale <- krige$micro.scale
  ##
  ## checking input
  ##
  if(micro.scale > nugget)
    stop("krige.conv: krige$micro.scale must be in the interval [0, nugget]")
  if (krige$type.krige != "ok" & krige$type.krige != "OK" & krige$type.krige != "o.k." & krige$type.krige != "O.K." & krige$type.krige != "sk" & krige$type.krige != "SK" & krige$type.krige != "s.k." & krige$type.krige != "S.K.")
    stop("krige.conv: wrong option in the argument type.krige. It should be \"OK\" or \"SK\"(if ordinary or simple kriging is to be performed)")
  if (krige$type.krige == "ok" | krige$type.krige == "OK" | krige$type.krige == "o.k." | krige$type.krige == "O.K.") 
    beta.prior <- "flat"
  if (krige$type.krige == "sk" | krige$type.krige == "SK" | krige$type.krige == "s.k." | krige$type.krige == "S.K."){
    if(is.null(beta) | !is.numeric(beta))
      stop("krige.conv: argument beta must be provided in order to perform simple kriging")
    beta.prior <- "deg"
  }
  ##
  if(is.vector(coords)){
    coords <- cbind(coords, 0)
    warning("krige.conv: vector of coordinates, one spatial dimension assumed")
  }
  coords <- as.matrix(coords)
  if (is.vector(locations)) {
    if (length(locations) == 2) {
      locations <- t(as.matrix(locations))
      if (messages.screen) 
        warning("krige.conv: assuming that there is 1 prediction point")
    }
    else{
      warning("krige.conv: vector of locations: one spatial dimension assumed")
      locations <- as.matrix(cbind(locations, 0))
    }
  }
  else locations <- as.matrix(locations)  
  dimnames(coords) <- list(NULL, NULL)
  dimnames(locations) <- list(NULL, NULL)
  ##
  if(inherits(krige$trend.d, "formula") | inherits(krige$trend.l, "formula")){
    if((inherits(krige$trend.d, "formula") == FALSE) | (inherits(krige$trend.l, "formula") == FALSE))
      stop("krige.conv: krige$trend.d and krige$trend.l must have similar specification")
    if(messages.screen)
      cat("krige.conv: Kriging with external trend to be performed using covariates provided by the user\n")
  }
  else{
    if (krige$trend.d != krige$trend.l){
      stop("krige.conv: krige$trend.l is different from krige$trend.d")
    }
    if(messages.screen){
      if(krige$trend.d == "cte" & krige$type.krige == "sk")
        cat("krige.conv: Simple kriging to be performed with constant mean provided by the user\n"
            )
      if(krige$trend.d == "cte" & krige$type.krige == "ok")
        cat("krige.conv: Ordinary kriging to be performed filtering a constant mean\n")
      if(krige$trend.d == "1st")
        cat("krige.conv: Trend (or universal) kriging to be performed filtering a 1st degree polinomial trend\n")
      if(krige$trend.d == "2nd") 
        cat("krige.conv: Trend (or universal) kriging to be performed filtering a 2nd degree polinomial trend\n")
    }
  }
  trend.d <- trend.spatial(trend=krige$trend.d, coords=coords)
  beta.size <- ncol(trend.d)
  trend.l <- trend.spatial(trend=krige$trend.l, coords=locations)
  ##
  ## Anisotropy correction (should be placed AFTER trend.d/trend.l
  ##
  if(!is.null(krige$aniso.pars)) {
    if(length(krige$aniso.pars) != 2 | !is.numeric(krige$aniso.pars))
      stop("krige.conv: anisotropy parameters must be provided as a numeric vector with two elements: the rotation angle (in radians) and the anisotropy ratio (a number greater than 1)")
    if(messages.screen)
      cat("krige.conv: anisotropy correction performed\n")
    coords <- coords.aniso(coords = coords, aniso.pars = krige$aniso.pars)
    locations <- coords.aniso(coords = locations, aniso.pars = krige$aniso.pars)
  }
  ##
  ## Box-Cox transformation
  ##
  if(lambda != 1) {
    if(messages.screen)
      cat("krige.conv: Box-Cox's transformation of the data was performed.\n")
    if(lambda == 0)
      data <- log(data)
    else data <- ((data^lambda) - 1)/lambda
  }  
  ## 
  ## setting covariance parameters
  ##
  if (is.vector(cov.pars)) {
    sigmasq <- cov.pars[1]
    phi <- cov.pars[2]
  }
  else {
    sigmasq <- cov.pars[, 1]
    phi <- cov.pars[, 2]
  }
  sill.partial <- micro.scale + sum(sigmasq)
  sill.total <- nugget + sum(sigmasq)
  n <- length(data)
  ni <- nrow(trend.l)
  ##
  ## starting kriging calculations
  ##
  kc.result <- list()
### old code
  ##  invcov <- varcov.spatial(coords = coords, cov.model = cov.model, 
  ##                           kappa = kappa, nugget = nugget,
  ##                           cov.pars = cov.pars, inv = TRUE)$inverse
  ##  ttiv <- crossprod(trend.d, invcov)
  ##  ittivtt <- solve(ttiv %*% trend.d)
  invcov <- varcov.spatial(coords = coords, cov.model = cov.model, 
                               kappa = kappa, nugget = nugget,
                               cov.pars = cov.pars, inv = TRUE,
                               only.inv.lower.diag = TRUE)
  temp <- as.double(rep(0, beta.size * beta.size))
  temp <- .C("bilinearform_XAY",
             as.double(invcov$lower.inverse),
             as.double(invcov$diag.inverse),
             as.double(as.vector(trend.d)),
             as.double(as.vector(trend.d)),
             as.integer(beta.size),
             as.integer(beta.size),
             as.integer(n),
             res=temp)$res
  attr(temp, "dim") <- c(beta.size, beta.size)
  ittivtt <- solve(temp)
  remove("temp")
  if (beta.prior == "flat"){
### old code
    ##    beta.flat <- ittivtt %*% ttiv %*% data
    temp <- as.double(rep(0, beta.size))
    temp <- .C("bilinearform_XAY",
               as.double(invcov$lower.inverse),
               as.double(invcov$diag.inverse),
               as.double(as.vector(trend.d)),
               as.double(as.vector(data)),
               as.integer(beta.size),
               as.integer(1),
               as.integer(n),
               res=temp)$res
    beta.flat <- ittivtt %*% temp
    remove("temp")
    
  }
  v0mat <- as.double(rep(0, n*ni))
  .C("loccoords",
     as.double(as.vector(locations[,1])),
     as.double(as.vector(locations[,2])),
     as.double(as.vector(coords[,1])),
     as.double(as.vector(coords[,2])),
     as.integer(ni),
     as.integer(n),
     v0mat, DUP=FALSE)
  attr(v0mat, "dim") <- c(n, ni)
  if(n.sim > 0){
    ## checking data points coincident with prediction locations
    loc.coincide <- apply(v0mat, 2, function(x, min.dist){any(x < min.dist)},min.dist=krige$dist.epsilon)
    if(any(loc.coincide))
      loc.coincide <- (1:ni)[loc.coincide]
    else
      loc.coincide <- NULL
    if(!is.null(loc.coincide)){
      temp.f <- function(x, data, dist.eps){return(data[x < dist.eps])}
      data.coincide <- apply(v0mat[, loc.coincide, drop=FALSE], 2, temp.f, data=data, dist.eps=krige$dist.epsilon)
    }
    else
      data.coincide <- NULL
  }
  else
    remove("locations")
  if(signal){
    v0mat <- ifelse(v0mat < krige$dist.epsilon, sill.partial,
                    cov.spatial(obj = v0mat, cov.model = cov.model, 
                                kappa = kappa, cov.pars = cov.pars))
  }
  else{
    v0mat <- ifelse(v0mat < krige$dist.epsilon, sill.total,
                    cov.spatial(obj = v0mat, cov.model = cov.model, 
                                kappa = kappa, cov.pars = cov.pars))
  }   
### old code
  ##  tv0iv <- t(apply(v0mat, 2, crossprod, y = invcov))
  ##  remove("invcov")	
  ##  if(n.sim > 0) {
  ##    reduce.var <- tv0iv %*% v0mat
  ##    tv0ivv0 <- diag(reduce.var)
  ##  }
  ##  else
  ##    tv0ivv0 <- diag(tv0iv %*% v0mat)
  tv0ivv0 <- as.double(rep(0,ni))
  tv0ivv0 <- .C("diag_quadraticform_XAX",
                as.double(invcov$lower.inverse),
                as.double(invcov$diag.inverse),
                as.double(as.vector(v0mat)),
                as.integer(ni),
                as.integer(n),
                res = tv0ivv0)$res
### old code
  ##  tb <- t(trend.l) - apply(tv0iv, 1, crossprod, y = trend.d)
  ##  tb <- trend.l - tv0iv %*% trend.d
  tb <- as.double(rep(0, ni*beta.size))
  tb <- .C("bilinearform_XAY",
           as.double(invcov$lower.inverse),
           as.double(invcov$diag.inverse),
           as.double(as.vector(v0mat)),
           as.double(as.vector(trend.d)),
           as.integer(ni),
           as.integer(beta.size),
           as.integer(n),
           res=tb)$res
  attr(tb, "dim") <- c(ni, beta.size)
  tb <- trend.l - tb
###  
  if (beta.prior == "deg") {
### old code    
    ##    kc.result$predict <- as.vector((tv0iv %*% data) + (tb %*% beta))
    tv0ivdata <- as.double(rep(0,ni))
    tv0ivdata <- .C("bilinearform_XAY",
                    as.double(invcov$lower.inverse),
                    as.double(invcov$diag.inverse),
                    as.double(as.vector(v0mat)),
                    as.double(data),
                    as.integer(ni),
                    as.integer(1),
                    as.integer(n),
                    res = tv0ivdata)$res
    if(n.sim == 0) remove("v0mat","invcov")
    kc.result$predict <- tv0ivdata + as.vector(tb %*% beta)
    if(n.sim == 0) remove("tb")
    remove("tv0ivdata")
    if (krige$signal) 
      kc.result$krige.var <- as.vector(sill.partial - tv0ivv0)
    else kc.result$krige.var <- as.vector(sill.total - tv0ivv0)
    beta.est <- "Simple kriging performed (beta provided by user)"
  }
  if (beta.prior == "flat"){
### old    
    ##    kc.result$predict <- as.vector((tv0iv %*% data) + (tb %*% beta.flat))
    tv0ivdata <- as.double(rep(0,ni))
    tv0ivdata <- .C("bilinearform_XAY",
                    as.double(invcov$lower.inverse),
                    as.double(invcov$diag.inverse),
                    as.double(as.vector(v0mat)),
                    as.double(data),
                    as.integer(ni),
                    as.integer(1),
                    as.integer(n),
                    res = tv0ivdata)$res
    if(n.sim == 0) remove("v0mat","invcov")
    kc.result$predict <- tv0ivdata + as.vector(tb %*% beta.flat)
    remove("tv0ivdata")
### old code    
    ##    bi <- tb %*% ittivtt
    ##    if(n.sim > 0) {
    ##      ok.add.var <- bi %*% t(tb)
    ##      reduce.var <- reduce.var + ok.add.var
    ##      bitb <- diag(ok.add.var)
    ##    }
    ##    else
    ##      bitb <- diag(bi %*% t(tb))
    if(beta.size == 1)
      bitb <- as.vector(tb^2) * as.vector(ittivtt)
    else{
      bitb <- as.double(rep(0,ni))
      bitb <- .C("diag_quadraticform_XAX",
                 as.double(ittivtt[lower.tri(ittivtt)]),
                 as.double(diag(ittivtt)),
                 as.double(as.vector(t(tb))),
                 as.integer(ni),
                 as.integer(beta.size),
                 res = bitb)$res
    }
    if(n.sim == 0) remove("tb")
    if (krige$signal) 
      kc.result$krige.var <- as.vector(sill.partial - tv0ivv0 + bitb)
    else kc.result$krige.var <- as.vector(sill.total - tv0ivv0 + bitb)
    kc.result$beta.est <- beta.flat
    remove("bitb")
  }
  remove("tv0ivv0")
  if(any(round(kc.result$krige.var, dig=12) < 0))
    cat("krige.conv: negative kriging variance found! Investigate why this is happening.\n")
  message <- "krige.conv: Kriging performed using global neighbourhood"
  if(messages.screen)
    cat(paste(message, "\n"))
############## Sampling from the resulting distribution #####################
  if(n.sim > 0) {
    if(messages.screen)
      cat("krige.conv: sampling from the predictive distribution (conditional simulations)\n")
    if(length(cov.pars) > 2){
      reduce.var <- as.double(rep(0, ni * ni))
      .C("bilinearform_XAY",
         as.double(invcov$lower.inverse),
         as.double(invcov$diag.inverse),
         as.double(as.vector(v0mat)),
         as.double(as.vector(v0mat)),
         as.integer(ni),
         as.integer(ni),
         as.integer(n),
         reduce.var, DUP=FALSE)
      remove("v0mat")
      attr(reduce.var, "dim") <- c(ni, ni)
      if(beta.prior == "flat"){
        if(beta.size == 1)
          ok.add.var <- outer(as.vector(tb),as.vector(tb)) * as.vector(ittivtt)
        else{
          b <- t(tb)
          remove("tb")
          ok.add.var <- as.double(rep(0,ni*ni))
          .C("bilinearform_XAY",
             as.double(ittivtt[lower.tri(ittivtt)]),
             as.double(diag(ittivtt)),
             as.double(as.vector(b)),
             as.double(as.vector(b)),
             as.integer(ni),
             as.integer(ni),
             as.integer(beta.size),
             ok.add.var, DUP=FALSE)
          attr(ok.add.var, "dim") <- c(ni, ni)
          remove("b")
        }
        reduce.var <- reduce.var + ok.add.var
      }
      varcov <- varcov.spatial(coords = locations,
                               cov.model = cov.model,
                               cov.pars = cov.pars,
                               kappa = kappa, nugget = nugget)$varcov - reduce.var
      remove("reduce.var")
      if(is.R()) gc(verbose=FALSE)
      kc.result$simulations <-  kc.result$predict + crossprod(chol(varcov), matrix(rnorm(ni * n.sim), ncol=n.sim))
    }
    else{
      if(((round(1e12 * nugget) == 0) | signal) & (!is.null(loc.coincide))){
        v0mat <- v0mat[,-(loc.coincide)]
        nloc <- ni - length(loc.coincide)
        tmean.coincide <- kc.result$predict[loc.coincide]
        tmean <- kc.result$predict[-(loc.coincide)]
        tb <- tb[-(loc.coincide),]
      }
      else{
        nloc <- ni
        tmean <- kc.result$predict
      }
      normalsc <-  rnorm(nloc*n.sim)
      if (signal) Dval <- 1.0 + micro.scale
      else Dval <-  1.0 + (nugget/cov.pars[1])
      if(beta.size == 1){
        Blower <- 0
        if(beta.prior == "flat")
          Bdiag <- ittivtt
        else
          Bdiag <- 0.0
      }
      else{
        Blower <-  ittivtt[lower.tri(ittivtt)]
        if(beta.prior == "flat")
          Bdiag <-   diag(ittivtt)
        else
          Bdiag <- rep(0, beta.size)
      }
      R0 <- as.double(rep(0.0, (nloc*(nloc+1))/2))
      if(((round(1e12 * nugget) == 0) | signal) & (!is.null(loc.coincide))){
        .C("distdiag",
           as.double(locations[-(loc.coincide),1]),
           as.double(locations[-(loc.coincide),2]),
           as.integer(nloc),
           R0, DUP = FALSE)
      }
      else
        .C("distdiag",
           as.double(locations[,1]),
           as.double(locations[,2]),
           as.integer(ni),
           R0, DUP = FALSE)
      remove("locations")
      R0 <- cov.spatial(R0, cov.pars=cov.pars, cov.model=cov.model, kappa=kappa)
      normalsc <- .C("kb_sim",
                     as.double(tmean),
                     out = as.double(as.vector(normalsc)),
                     as.double(invcov$lower.inverse),
                     as.double(invcov$diag.inverse),
                     as.double(as.vector(v0mat)),
                     as.integer(nloc),
                     as.integer(n),
                     as.double(Dval),
                     as.integer(n.sim),
                     as.double(rep(1, n.sim)),                      
                     as.double(sill.partial),                      
                     as.double(Blower),
                     as.double(Bdiag),
                     as.double(as.vector(t(tb))),
                     as.integer(beta.size),
                     as.double(R0))$out
      attr(normalsc, "dim") <- c(nloc, n.sim)
      remove("v0mat", "R0", "tb", "invcov")
      if(((round(1e12 * nugget) == 0) | signal) & (!is.null(loc.coincide))){
        kc.result$simulations <- matrix(0, nrow=ni, ncol=n.sim)
        kc.result$simulations[-(loc.coincide),] <- normalsc
        kc.result$simulations[loc.coincide,] <- rep(tmean.coincide, n.sim)
      }
      else
        kc.result$simulations <- normalsc
      remove("normalsc")
    }
    if(lambda != 1){
      cat("krige.conv: back-transforming the simulated values\n")
      if(any(kc.result$simulations < -1/lambda))
        warning("Truncation in the back-transformation: there are simulated values less than (- 1/lambda) in the normal scale.")
      if(lambda == 0)
        kc.result$simulations <- ifelse(kc.result$simulations > -1/lambda, exp(kc.result$simulations), -1/lambda)
      if(lambda > 0)
        kc.result$simulations <- ifelse(kc.result$simulations > -1/lambda, ((kc.result$simulations*lambda) + 1)^(1/lambda), -1/lambda)
      if(lambda < 0)
        warning("back transformation not performed (negative value of lambda)")
    }
  }
########### Back - transforming predictions############################
  if(lambda != 1) {
    if(messages.screen)
      cat("krige.conv: back-transforming the predictions according to the (Box-Cox) parameter lambda\n")
    kc.result$transf.predict <- kc.result$predict
    kc.result$transf.krige.var <- kc.result$krige.var
    if(lambda == 0 & beta.prior == "deg") {
## don't change the order of the next two commands!!!
      kc.result$predict <- exp(kc.result$transf.predict + 0.5 * kc.result$krige.var)
      kc.result$krige.var <- (kc.result$predict^2) * (exp(kc.result$krige.var) -1)
    }
    if(lambda > 0 | (lambda == 0 & beta.prior == "flat")) {
      if(messages.screen)
        cat("krige.conv: back-transformation done by sampling from the resulting (normal) predictive distribution (inspect results carefully, run the function more than once and check for stability of the results\n")
      ap.warn <- options()$warn
      options(warn = -1)
      temp.data <- matrix(rnorm(ni * n.samples.backtransform,
                                mean = kc.result$transf.predict,
                                sd = sqrt(kc.result$transf.krige.var)),
                          nrow = ni)
      options(warn = ap.warn)
      ind.zero <- (round(1e12*kc.result$transf.krige.var) == 0)
      temp.data[ind.zero,  ] <- kc.result$transf.predict[ind.zero]
      remove(ind.zero)
      if(lambda == 0)
        temp.data <- exp(temp.data)
      else{
        temp.data[temp.data < -1/lambda] <- -1/lambda
        temp.data <- ((temp.data * lambda) + 1)^(1/lambda)
###      temp.data[is.na(temp.data)] <- Inf
      }
      kc.result$predict <- as.vector(apply(temp.data, 1, mean))
      kc.result$krige.var <- as.vector(apply(temp.data, 1, var))
    }
    if(lambda < 0) {
      cat("krige.conv: resulting distribution has no mean for lambda < 0 - back transformation not performed. Consider quantiles estimators\n"
          )
      kc.result$predict <- "back-transformation not performed"
      kc.result$krige.var <- "back-transformation not performed"
    }
  }
  kc.result <- c(kc.result, list(message = message, call = call.fc))
#####################################
  class(kc.result) <- "kriging"
  return(kc.result)
}

"krige.control" <-
  function (type.krige = "ok", beta = NULL,  
            trend.d = "cte", trend.l = "cte",
            cov.model = "matern",
            cov.pars = stop("covariance parameters (sigmasq and phi) should be provided"), kappa = 0.5,
            nugget = 0, micro.scale = 0, dist.epsilon = 1e-10, 
            aniso.pars = NULL, lambda = 1, 
            signal = FALSE,
            n.samples.backtransform = 500, n.sim = 0)
{
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  return(list(type.krige = type.krige, beta = beta,
              trend.d = trend.d, trend.l = trend.l, 
              cov.model = cov.model, 
              cov.pars = cov.pars, kappa = kappa,
              nugget = nugget,
              micro.scale = micro.scale, dist.epsilon = dist.epsilon, 
              aniso.pars = aniso.pars, lambda = lambda,
              signal = signal,
              n.samples.backtransform = n.samples.backtransform,
              n.sim = n.sim))
}


"prepare.graph.kriging" <-
  function (obj, locations, borders, values) 
{
  if(!is.null(borders)){
    borders <- as.matrix(as.data.frame(borders))
    if(is.R())
      require(splancs)
    inout.vec <- as.vector(inout(pts = locations, poly = borders))
    if(sum(inout.vec) != length(values))
      stop("image.kriging: length of the argument values is incompatible with number of elements inside the borders.")
    temp <- rep(NA, nrow(locations))
    temp[inout.vec == T] <- values
    values <- temp
    remove("temp")
  }
  locations <- locations[order(locations[, 2], locations[,1]), ]
  x <- as.numeric(levels(as.factor(locations[, 1])))
  nx <- length(x)
  y <- as.numeric(levels(as.factor(locations[, 2])))
  ny <- length(y)
  coords.lims <- set.coords.lims(coords=locations)
  return(list(x=x, y=y, values = matrix(values,ncol=ny), coords.lims=coords.lims))
}

"image.kriging" <-
  function (obj, locations, borders, 
            values = obj$predict, coords.data, ...) 
{
  if(missing(borders)) borders <- NULL
  if(missing(coords.data)) coords.data <- NULL
  locations <- prepare.graph.kriging(obj=obj, locations=locations,
                                     borders=borders, values=values) 
  pty.prev <- par()$pty
  par(pty = "s")
  image(locations$x, locations$y, locations$values,
        xlim= locations$coords.lims[,1], ylim=locations$coords.lims[,2],...)
  if(!is.null(coords.data))
    points(coords.data)
  if(!is.null(borders))
    lines(borders, lwd=2)
  par(pty.prev)
  return(invisible())
}

"persp.kriging" <-
  function(obj, locations, borders, values = obj$predict, ...)
{
  if(missing(borders)) borders <- NULL
  locations <- prepare.graph.kriging(obj=obj, locations=locations,
                                     borders=borders, values=values) 
  persp(locations$x, locations$y, locations$values, ...)
  return(invisible())
}

"likfit" <-
  function (geodata, coords=geodata$coords, data=geodata$data,
            trend = "cte", ini.cov.pars,
            fix.nugget = FALSE, nugget = 0, 
            fix.kappa = TRUE, kappa = 0.5, 
            fix.lambda = TRUE, lambda = 1, 
            fix.psiA = TRUE, psiA = 0, 
            fix.psiR = TRUE, psiR = 1, 
            cov.model = "matern",
            method = "ML",
            components = FALSE, nospatial = TRUE,
            limits = likfit.limits(), 
            print.pars = FALSE, messages.screen = TRUE, ...) 
{
  ##
  ## Checking input
  ##
  if(is.R()) require(mva)
  call.fc <- match.call()
  temp.list <- list()
  temp.list$print.pars <- print.pars
  ##
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  temp.list$cov.model <- cov.model
  ##
  if(cov.model == "powered.exponential")
    if(limits$kappa["upper"] > 2) limits$kappa["upper"] <- 2
  ##
  if(method == "REML" | method == "reml" | method == "rml") 
    method <- "RML"
  if(method == "ML" | method == "ml")
    method <- "ML"
  if(method == "ML" & cov.model == "power")
    stop("\n\"power\" model can only be used with method=\"RML\".\nBe sure that what you want is not \"powered.exponential\"")
  temp.list$method <- method
  if(is.matrix(ini.cov.pars) | is.data.frame(ini.cov.pars)){
    ini.cov.pars <- as.matrix(ini.cov.pars)
    if(nrow(ini.cov.pars) == 1)
      ini.cov.pars <- as.vector(ini.cov.pars)
    else{
      if((cov.model != "pure.nugget") & (ncol(ini.cov.pars) != 2))
        stop("\nini.cov.pars must be a matrix or data.frame with 2 components: \ninitial values for sigmasq and phi")
    }
  }
  if(is.vector(ini.cov.pars)){
    if((cov.model != "pure.nugget") & (length(ini.cov.pars) != 2))
      stop("\nini.cov.pars must be a vector with 2 components: \ninitial values for sigmasq and phi")
  }
  if(fix.kappa & !is.null(kappa))
    if(cov.model == "matern" & kappa == 0.5)
      cov.model <- "exponential"
  coords <- temp.list$coords <- as.matrix(coords)
  n <- temp.list$n <- length(data)
  if((2*n) != length(coords))
    stop("\nnumber of locations does not match with number of data")
  temp.list$xmat <- trend.spatial(trend=trend, coords=coords)
  beta.size <- temp.list$beta.size <- dim(temp.list$xmat)[2]
  ##
  ## Checking for multiple initial values for preliminar search of   
  ## best initial value
  ##
  if(is.matrix(ini.cov.pars) | (length(nugget) > 1) | (length(kappa) > 1) | (length(lambda) > 1) | (length(psiR) > 1) | (length(psiA) > 1)){
    if(messages.screen)
      cat("likfit: searching for best initial value ...")
    .likGRF.dists.vec <<- as.vector(dist(coords))
    temp.list$z <- as.vector(data)
    temp.list$trend <- trend
    ini.temp <- matrix(ini.cov.pars, ncol=2)
    grid.ini <- as.matrix(expand.grid(sigmasq=unique(ini.temp[,1]), phi=unique(ini.temp[,2]), tausq=unique(nugget), kappa=unique(kappa), lambda=unique(lambda), psiR=unique(psiR), psiA=unique(psiA)))
    temp.f <- function(parms, temp.list){
      return(loglik.GRF(coords=temp.list$coords, data=temp.list$z, cov.model=temp.list$cov.model, cov.pars=parms[1:2], nugget=parms["tausq"], kappa=parms["kappa"], lambda=parms["lambda"], psiR=parms["psiR"], psiA=parms["psiA"], trend= temp.list$trend, method=temp.list$method, compute.dists=F))
    }
    grid.lik <- apply(grid.ini, 1, temp.f, temp.list=temp.list)
    ini.temp <- grid.ini[which(grid.lik == max(grid.lik)),, drop=FALSE]
    if(is.R()) rownames(ini.temp) <- "initial.value"
    if(messages.screen){
      cat(" selected values:\n")
      print(rbind(round(ini.temp, dig=2), status=ifelse(c(FALSE, FALSE, fix.nugget, fix.kappa, fix.lambda, fix.psiR, fix.psiA), "fix", "est")))
      cat(paste("likelihood value:", max(grid.lik), "\n"))
    }
    names(ini.temp) <- NULL
    ini.cov.pars <- ini.temp[1:2]
    nugget <- ini.temp[3]
    kappa <- ini.temp[4]
    lambda <- ini.temp[5]
    psiR <- ini.temp[6]
    psiA <- ini.temp[7]
    grid.ini <- NULL
    temp.list$trend <- NULL
    if(is.R()) {remove(".likGRF.dists.vec", pos=1); gc(verbose=FALSE)}    
    else remove(".likGRF.dists.vec", where=1)    
  }
  ##
  tausq <- nugget
  ##
  ## Box-Cox transformation for fixed lambda
  ##
  if(fix.lambda) {
    if(round(lambda, dig=4) == 1) {
      temp.list$log.jacobian <- 0
      temp.list$z <- as.vector(data)
    }
    else {
      if(any(data <= 0))
        stop("Transformation option not allowed when there are zeros or negative data")
      Jdata <- data^(lambda - 1)
      if(any(Jdata <= 0))
        temp.list$log.jacobian <- log(prod(Jdata))
      else temp.list$log.jacobian <- sum(log(Jdata))
      Jdata <- NULL
      if(is.R()) gc(verbose=FALSE)
      if(round(lambda, dig=4) == 0)
        temp.list$z <- log(data)
      else temp.list$z <- ((data^lambda) - 1)/lambda
    }
  }
  else{
    temp.list$z <- as.vector(data)
    temp.list$log.jacobian <- NULL
  }
  ##
  ## Coordinates transformation for fixed anisotropy parameters
  ##
  if(fix.psiR & fix.psiA){
    if(psiR != 1 | psiA != 0)
      coords <- coords.aniso(coords, aniso.pars=c(psiA, psiR))
    if(is.R()) assign(".likGRF.dists.vec", as.vector(dist(coords)), pos=1)
    else assign(".likGRF.dists.vec", as.vector(dist(coords)), where=1)
    range.dist <- range(.likGRF.dists.vec)
    max.dist <- max(range.dist)
    min.dist <- min(range.dist)
  }
  ##
  ##
  ##
  ini <- ini.cov.pars[2]
  ##  fixed.pars <- NULL
  lower.optim <- c(limits$phi["lower"])
  upper.optim <- c(limits$phi["upper"])
  fixed.values <- list()
  if(fix.nugget) {
    ##    fixed.pars <- c(fixed.pars, 0)
    fixed.values$tausq <- nugget
  }
  else {
    ini <- c(ini, nugget/ini.cov.pars[1])
    lower.optim <- c(lower.optim, limits$tausq.rel["lower"])
    upper.optim <- c(upper.optim, limits$tausq.rel["upper"])
  }
  if(fix.kappa){
##    fixed.kappa <- c(fixed.pars, kappa)
    fixed.values$kappa <- kappa
  }
  else {
    ini <- c(ini, kappa)
    lower.optim <- c(lower.optim, limits$kappa["lower"])
    upper.optim <- c(upper.optim, limits$kappa["upper"])
  }
  if(fix.lambda){
##    fixed.pars <- c(fixed.pars, lambda)
    fixed.values$lambda <- lambda
  }
  else {
    ini <- c(ini, lambda)
    lower.optim <- c(lower.optim, limits$lambda["lower"])
    upper.optim <- c(upper.optim, limits$lambda["upper"])
  }
  if(fix.psiR){
##    fixed.pars <- c(fixed.pars, psiR)
    fixed.values$psiR <- psiR
  }
  else {
    ini <- c(ini, psiR)
    lower.optim <- c(lower.optim, limits$psiR["lower"])
    upper.optim <- c(upper.optim, limits$psiR["upper"])
  }
  if(fix.psiA){
##    fixed.pars <- c(fixed.pars, psiA)
    fixed.values$psiA <- psiA
  }
  else {
    ini <- c(ini, psiA)
    lower.optim <- c(lower.optim, limits$psiA["lower"])
    upper.optim <- c(upper.optim, limits$psiA["upper"])
  }
  ## This must be here, after the previous ones:
  if(fix.nugget & nugget > 0){
    ## Warning: Inverting order here, ini will be now: c(phi,sigmasg)
    ini <- c(ini, ini.cov.pars[1])
    lower.optim <- c(lower.optim, limits$sigmasq["lower"])
    upper.optim <- c(upper.optim, limits$sigmasq["upper"])
##    fixed.pars <- c(fixed.pars, ini.cov.pars[1])
##    fixed.values$sigmasq <- 0
  }
  names(ini) <- NULL
  ##
  ip <- list(f.tausq = fix.nugget, f.kappa = fix.kappa, f.lambda = fix.lambda,
                  f.psiR = fix.psiR, f.psiA = fix.psiA)
  ##  
  if(messages.screen == TRUE) {
    cat("-------------------------------------------------------\n")
    cat("likfit: Initialising likelihood maximisation using the function ")
    if(is.R()) cat("optim.\n") else cat("nlminb.\n")
    cat("likfit: Use control() to pass arguments for the maximisation function.")
    cat("\n        For more details see documentation for ")
    if(is.R()) cat("optim.\n") else cat("nlminb.\n")        
    cat("likfit: It is highly advisable to run this function several\n        times with different initial values for the parameters.\n")
    cat("likfit: WARNING: This step can be time demanding!\n")
    cat("-------------------------------------------------------\n")
  }
  npars <- beta.size + 2 + sum(unlist(ip)==FALSE)
  if(is.R()){
    lik.minim <- optim(par = ini, fn = negloglik.GRF, method="L-BFGS-B",
                       lower=lower.optim, upper=upper.optim,
                       fp=fixed.values, ip=ip, temp.list = temp.list, ...)
  }
  else{
    lik.minim <- nlminb(ini, negloglik.GRF,
                        lower=lower.optim, upper=upper.optim,
                        fp=fixed.values, ip=ip, temp.list = temp.list, ...)
  }
  ##
  if(messages.screen == TRUE) 
    cat("likfit: end of numerical maximisation.\n")
  par.est <- lik.minim$par
  if(any(par.est < 0)) par.est <- round(par.est, dig=12)
  phi <- par.est[1]
  ##
  ## Values of the maximised likelihood
  ##
  if(is.R())
    value.min <- lik.minim$value
  else
    value.min <- lik.minim$objective
  if(method == "ML"){
    if(ip$f.tausq & (tausq > 0))
      loglik.max <-  (- value.min) + (n/2)*(-log(2*pi))
    else
      loglik.max <-  (- value.min) + (n/2)*(-log(2*pi) + log(n) -1)
  }
  if(method == "RML"){
    xx.eigen <- eigen(crossprod(temp.list$xmat), symmetric = TRUE, only.values = TRUE)
    if(ip$f.tausq & (tausq > 0))
      loglik.max <- (- value.min) - ((n-beta.size)/2)*(log(2*pi)) +
        0.5 * sum(log(xx.eigen$values))
    else
      loglik.max <- (- value.min) - ((n-beta.size)/2)*(log(2*pi)) +
        ((n-beta.size)/2)*(log(n-beta.size)) - ((n-beta.size)/2) +
          0.5 * sum(log(xx.eigen$values))
  }
  ##
  ## Assigning values for estimated parameters
  ##
  if(ip$f.tausq & ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    psiA <- par.est[2]
  }
  if(ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    psiR <- par.est[2]
  }
  if(ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    psiR <- par.est[2]
    psiA <- par.est[3]
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    lambda  <- par.est[2]
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    lambda  <- par.est[2]
    psiA <- par.est[3]
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    lambda  <- par.est[2]
    psiR <- par.est[3]
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    lambda  <- par.est[2]
    psiR <- par.est[3]
    psiA <- par.est[4]
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & ip$f.psiA){
    kappa  <-  par.est[2]
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    kappa  <-  par.est[2]
    psiA <- par.est[3]
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    kappa  <-  par.est[2]
    psiR <- par.est[3]
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    kappa  <-  par.est[2]
    psiR <- par.est[3]
    psiA <- par.est[4]
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    kappa <-  par.est[2]
    lambda <- par.est[3]
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    kappa <-  par.est[2]
    lambda <- par.est[3]
    psiA <- par.est[4]
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    kappa <-  par.est[2]
    lambda <- par.est[3]
    psiR<- par.est[4]
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    kappa <-  par.est[2]
    lambda <- par.est[3]
    psiR<- par.est[4]
    psiA<- par.est[5]
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    psiA<- par.est[3]
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
    psiR<- par.est[3]
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    psiR<- par.est[3]
    psiA<- par.est[4]
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
    lambda <- par.est[3]
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    lambda <- par.est[3]
    psiA <- par.est[4]
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
    lambda <- par.est[3]
    psiR <- par.est[4]
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    lambda <- par.est[3]
    psiR <- par.est[4]
    psiA <- par.est[5]
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
    psiA <- par.est[4]
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
    psiR <- par.est[4]
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
    psiR <- par.est[4]
    psiA <- par.est[5]
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
    lambda <- par.est[4]
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
    lambda <- par.est[4]
    psiA <- par.est[5]
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
    lambda <- par.est[4]
    psiR <- par.est[5]
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- par.est[2]
    kappa <-  par.est[3]
    lambda <- par.est[4]
    psiR <- par.est[5]
    psiA <- par.est[6]
  }
  ##
  if(fix.nugget & nugget > 0){
    sigmasq <- par.est[length(par.est)]
    if(sigmasq > 1e-12) tausq <- nugget/sigmasq
    check.sigmasq <- TRUE
  }
  else check.sigmasq <- FALSE
  ##
  ##
  ## Transforming data acccording to the estimated lambda (Box-Cox) parameter
  ##
  if(!fix.lambda) {
    if(round(lambda, dig=4) == 1) {
      log.jacobian.max <- 0
      temp.list$z <- data
    }
    else {
      if(any(data^(lambda - 1) <= 0))
        log.jacobian.max <- log(prod(data^(lambda - 1)))
      else log.jacobian.max <- sum(log(data^(lambda - 1)))
      temp.list$z <- ((data^lambda)-1)/lambda
    }
  }
  else{
    log.jacobian.max <- temp.list$log.jacobian
  }
  ##
  ## Transforming coords for estimated anisotropy (if the case)
  ##
  if(fix.psiR & fix.psiA){
    if(is.R()) remove(".likGRF.dists.vec", pos=1)
    else remove(".likGRF.dists.vec", where=1)
  }
  else{
    if(psiR != 1 | psiA != 0)
      coords <- coords.aniso(coords, aniso.pars=c(psiA, psiR))
    .likGRF.dists.vec <- as.vector(dist(coords))
    range.dist <- range(.likGRF.dists.vec)
    max.dist <- max(range.dist)
    min.dist <- min(range.dist)
    if(is.R()) remove(".likGRF.dists.vec")
    else remove(".likGRF.dists.vec", frame=sys.nframe())
  }      
  if(is.R()) gc(verbose=FALSE)
  ##
  ## Computing estimated beta and tausq/sigmasq (if the case)
  ##
  if((phi < 1e-12))
    siv <- diag(x=1/sqrt((1+tausq)), n)
  else{
    if(check.sigmasq){
      if(sigmasq < 1e-12){
        if(!fix.nugget)
          siv <- diag(x=1/sqrt((1+tausq)), n)
        else
          siv <- diag(x=1/sqrt((tausq)), n)          
      }
      else
        siv <- varcov.spatial(coords = coords, cov.model = cov.model,
                              kappa = kappa,
                              nugget = tausq, cov.pars = c(1, phi),
                              inv=TRUE, sqrt.inv = TRUE,
                              det = FALSE)$sqrt.inverse
    }
    else
      siv <- varcov.spatial(coords = coords, cov.model = cov.model,
                            kappa = kappa,
                            nugget = tausq, cov.pars = c(1, phi),
                            inv=TRUE, sqrt.inv = TRUE,
                            det = FALSE)$sqrt.inverse
  }
  sivx <- crossprod(siv, temp.list$xmat)
  xivx <- crossprod(sivx)
  sivy <- crossprod(siv, temp.list$z)
  xivy <- crossprod(sivx, sivy)
  betahat <- solve(xivx, xivy)
  res <- as.vector(temp.list$z - temp.list$xmat %*% betahat)
  if(!fix.nugget | (round(1e+12 * nugget) == 0)){
    res <- as.vector(temp.list$z - temp.list$xmat %*% betahat)
    ssres <- as.vector(crossprod(crossprod(siv,res)))
    if(method == "ML")
      sigmasq <- ssres/n
    else
      sigmasq <- ssres/(n - beta.size)
  }
  if(fix.nugget){
    if(nugget > 0)
      tausq <- nugget
  }
  else tausq <- tausq * sigmasq
  betahat.var <- solve(xivx)
  if(sigmasq > 1e-12) betahat.var <- sigmasq * betahat.var
#  if(!fix.nugget & phi < 1e-16){
#    tausq <- sigmasq + tausq
#    sigmasq <- 0
#  }
  n.model.pars <- beta.size+7
  par.su <- data.frame(status=rep(-9,n.model.pars))
  ind.par.su <- c(rep(0, beta.size), ip$f.tausq, 0, 0, ip$f.kappa,
                  ip$f.psiR, ip$f.psiA,ip$f.lambda)
  par.su$status <- ifelse(ind.par.su,"fixed", "estimated")
  par.su$values <- round(c(betahat, tausq, sigmasq, phi, kappa, psiR, psiA, lambda), dig=4)
  if(beta.size == 1) beta.name <- "beta"
  else beta.name <- paste("beta", 0:(beta.size-1), sep="")
  row.names(par.su) <- c(beta.name, "tausq", "sigmasq", "phi", "kappa",
                             "psiR", "psiA", "lambda")
  par.su <- par.su[c((1:(n.model.pars-3)), n.model.pars-1, n.model.pars-2, n.model.pars),] 
  ##
  ## Preparing output
  ##
  lik.results <- list(cov.model = cov.model,
                      nugget = tausq,
                      cov.pars=c(sigmasq, phi),
                      kappa = kappa,
                      beta = as.vector(betahat),
                      beta.var = betahat.var,
                      lambda = lambda,
                      aniso.pars = c(psiA = psiA, psiR = psiR),
                      method = method, trend = trend,
                      loglik = loglik.max,
                      npars = npars,
                      AIC = (loglik.max - npars),
                      BIC = (loglik.max - 0.5 * log(n) * npars),
                      parameters.summary = par.su,
                      info.minimisation.function = lik.minim,
                      max.dist = max.dist,
                      trend.matrix= temp.list$xmat,
                      transform.info = list(fix.lambda = fix.lambda,
                        log.jacobian = log.jacobian.max))
  ##
  ## Likelihood results for the model without spatial correlation
  ##
  if(nospatial){
    if(fix.lambda){
      beta.ns <- solve(crossprod(temp.list$xmat), crossprod(temp.list$xmat, temp.list$z))
      ss.ns <- sum((as.vector(temp.list$z - temp.list$xmat %*% beta.ns))^2)
      if(method == "ML"){
        nugget.ns <- ss.ns/n
        loglik.ns <- (n/2)*((-log(2*pi)) - log(nugget.ns) - 1) + temp.list$log.jacobian
      }
      if(method == "RML"){
        nugget.ns <- ss.ns/(n-beta.size)
        loglik.ns <- ((n-beta.size)/2)*((-log(2*pi)) - log(nugget.ns) -1) + temp.list$log.jacobian
      }
      npars.ns <- beta.size + 1 + fix.lambda
      lambda.ns <- lambda
    }
    else{
      bc.list <- list(n = n, beta.size = beta.size,
                      data = data, xmat = temp.list$xmat,
                      method = method)
      if(is.R())
        lik.lambda.ns <- optim(par=1, fn = boxcox.ns, method="L-BFGS-B",
                               lower=limits$lambda["lower"], upper=limits$lambda["upper"], bc.list=bc.list)
      else
        lik.lambda.ns <- nlminb(par=1, fn = boxcox.ns,
                                lower=limits$lambda["lower"], upper=limits$lambda["upper"], data=data,
                                bc.list = bc.list)
      bc.list <- NULL
      if(is.R()) gc(verbose=FALSE)
      lambda.ns <- lik.lambda.ns$par
      tdata.ns <- ((data^lambda.ns)-1)/lambda.ns
      beta.ns <- solve(crossprod(temp.list$xmat),crossprod(temp.list$xmat,tdata.ns))
      ss.ns <- sum((as.vector(tdata.ns - temp.list$xmat %*% beta.ns))^2)
      if(is.R())
        value.min.ns <- lik.lambda.ns$value
      else
        value.min.ns <- lik.lambda.ns$objective
      if(method == "ML"){
        loglik.ns <- (- value.min.ns)+ (n/2)*((-log(2*pi)) + log(n) - 1)
        nugget.ns <- ss.ns/n
      }
      if(method == "RML"){
        nugget.ns <- ss.ns/(n-beta.size)
        loglik.ns <- (- value.min.ns)+ ((n-beta.size)/2)*((-log(2*pi)) +
                                                          log(n-beta.size) - 1)
      }      
      npars.ns <- beta.size + 1 + fix.lambda
    }
    lik.results$nospatial <- list(beta.ns = beta.ns, variance.ns = nugget.ns,
                                  loglik.ns = loglik.ns, npars.ns = npars.ns,
                                  lambda.ns = lambda.ns)
  }
  ##
  ## Computing residuals and predicted values
  ## (isolated components of the model)
  ##
  if(components) {
    if(!fix.psiR & !fix.psiA)
      if(psiR != 1 | psiA != 0)
        coords <- coords.aniso(coords, aniso.pars=c(psiA, psiR))
    trend.comp <- temp.list$z - res
    invcov <- varcov.spatial(coords = coords, cov.model = cov.model, 
                             kappa = kappa, nugget = tausq,
                             cov.pars = c(sigmasq, phi), inv=TRUE)$inverse 
    covmat.signal <- varcov.spatial(coords = coords, cov.model = cov.model, 
                                    kappa = kappa, nugget = 0,
                                    cov.pars = c(sigmasq, phi))$varcov
    spatial.comp <- as.vector(covmat.signal %*% invcov %*% res)
    predict.comp <- trend.comp + spatial.comp
    residual.comp <- as.vector(temp.list$z - predict.comp)
    residual.std <- as.vector(invcov %*% residual.comp)
    residual.trend.std <- as.vector(invcov %*% res)
    s2.random <- (crossprod(res,invcov) %*% res)/(n - beta.size)
    s2 <- (crossprod(residual.comp,invcov) %*% residual.comp)/(n - beta.size)
  }
  ##
  ## Assigning names to the components of the mean vector beta
  ##
  if(length(lik.results$beta.var) == 1)
    lik.results$beta.var <- as.vector(lik.results$beta.var)
  if(length(lik.results$beta) > 1){
    if(inherits(trend, "formula"))
      beta.names <- c("intercept", paste("covar", 1:(ncol(temp.list$xmat)-1), sep = ""))
    else
      if(trend == "1st")
        beta.names <- c("intercept", "x", "y")
      else
        if(trend == "2nd")
          beta.names <- c("intercept", "x", "y", "x2", "xy", "y2")
    names(lik.results$beta) <- beta.names
  }
  ##
  ## including residuals in the output
  ##
  if(components) {
    lik.results$model.components <- data.frame(trend = trend.comp, spatial = spatial.comp, residuals = residual.comp)
    lik.results$s2 <- s2
    lik.results$s2.random <- s2.random
  }
  ##
  lik.results$call <- call.fc
  ##
  ## Assigning classes
  ##
  if(is.R())
    class(lik.results) <- c("likGRF", "variomodel")
  else{
    if(version$major <= 4)
      class(lik.results) <- c("likGRF", "variomodel")
    else oldClass(lik.results) <- c("likGRF", "variomodel")
  }
  ##
  ## Some warning messages about particular possible results
  ##
  if(messages.screen){
    if((lik.results$cov.pars[1] < (0.01 * (lik.results$nugget + lik.results$cov.pars[1])))& lik.results$cov.pars[2] > 0)
      cat("\nWARNING: estimated sill is less than 1 hundredth of the total variance. Consider re-examine the model excluding spatial dependence\n" )      
    if((lik.results$cov.pars[2] > (10 * max.dist)) & lik.results$cov.pars[1] > 0 )
      cat("\nWARNING: estimated range is more than 10 times bigger than the biggest distance between two points. Consider re-examine the model:\n 1) excluding spatial dependence if estimated sill is too low and/or \n 2) taking trends (covariates) into account\n" ) 
    if(((lik.results$cov.pars[2] < (0.1 * min.dist)) & (lik.results$cov.pars[1] > 0)) & lik.results$cov.pars[2] > 0)
      cat("\nWARNING: estimated range is less than 1 tenth of the minimum distance between two points. Consider re-examine the model excluding spatial dependence\n" ) 

  }
  ##
  return(lik.results)
}

"negloglik.GRF" <-
  function(pars, fp, ip, temp.list)
### pars : values for the parameters to be estimated
  ## sequence is c(phi, tausq, kappa, lambda, psiR, psiA, sigmasq)
### fixed pars: parameters considered fixed
### ind.pars : list indicating which are fixed and which are to be estimated
  ##
  ## Warning:
  ##  if fix.nugget = TRUE and nugget > 0 ,
  ## sigmasq should be passed and fp$nugget is the value of the nugget
  ## otherwise the RELATIVE nugget should be passed
{
  n <- temp.list$n
  p <- temp.list$beta.size
  log.jacobian <- temp.list$log.jacobian
  ## Obligatory parameter:
  phi <- pars[1]
  ## Others
  if(ip$f.tausq){
    if(fp$tausq > 0){
      npars.min <- length(pars)
      sigmasq <- pars[npars.min]
    }
    else sigmasq <- 1
  }
  else sigmasq <- 1
  if(ip$f.tausq & ip$f.kappa & ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(ip$f.tausq & ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- pars[2]
  }
  if(ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- pars[2]
    psiA <- fp$psiA
  }
  if(ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- pars[2]
    psiA <- pars[3]
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- pars[2]
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- pars[2]
    psiR <- fp$psiR
    psiA <- pars[3]
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- pars[2]
    psiR <- pars[3]
    psiA <- fp$psiA
  }
  if(ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- fp$kappa
    lambda <- pars[2]
    psiR <- pars[3]
    psiA <- pars[4]
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- pars[3]
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- fp$lambda
    psiR <- pars[3]
    psiA <- fp$psiA
  }
  if(ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- fp$lambda
    psiR <- pars[3]
    psiA <- pars[4]
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- pars[3]
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- pars[3]
    psiR <- fp$psiR
    psiA <- pars[4]
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- pars[3]
    psiR <- pars[4]
    psiA <- fp$psiA
  }
  if(ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- fp$tausq
    kappa <- pars[2]
    lambda <- pars[3]
    psiR <- pars[4]
    psiA <- pars[5]
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- pars[3]
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- pars[3]
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- fp$lambda
    psiR <- pars[3]
    psiA <- pars[4]
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- pars[3]
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- pars[3]
    psiR <- fp$psiR
    psiA <- pars[4]
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- pars[3]
    psiR <- pars[4]
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- fp$kappa
    lambda <- pars[3]
    psiR <- pars[4]
    psiA <- pars[5]
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- fp$lambda
    psiR <- fp$psiR
    psiA <- pars[4]
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- fp$lambda
    psiR <- pars[4]
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & !ip$f.kappa & ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- fp$lambda
    psiR <- pars[4]
    psiA <- pars[5]
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- pars[4]
    psiR <- fp$psiR
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- pars[4]
    psiR <- fp$psiR
    psiA <- pars[5]
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- pars[4]
    psiR <- pars[5]
    psiA <- fp$psiA
  }
  if(!ip$f.tausq & !ip$f.kappa & !ip$f.lambda & !ip$f.psiR & !ip$f.psiA){
    tausq <- pars[2]
    kappa <- pars[3]
    lambda <- pars[4]
    psiR <- pars[5]
    psiA <- pars[6]
  }
  ##
  if(temp.list$print.pars){
    running.pars <- c(sigmasq, phi, tausq, kappa, psiA, psiR, lambda)
    names(running.pars) <- c("sigmasq", "phi", "tausq", "kappa", "psiA", "psiR", "lambda")
    print(running.pars)
  }
  ##
  ## Absurd values
  ##
  if(kappa < 1e-04) return(.Machine$double.xmax/10000)
  if(round(1e+16*(tausq+sigmasq)) == 0) return(.Machine$double.xmax/10000)
#  if(kappa < 1e-04) return(1e64)
#  if(round(1e+16*(tausq+sigmasq)) == 0) return(1e64)
  ##
  ## Anisotropy
  ##
  if(!ip$f.psiR | !ip$f.psiA){
    coords.c <- coords.aniso(temp.list$coords, aniso.pars=c(psiA, psiR))
    if(is.R()) assign(".likGRF.dists.vec", as.vector(dist(coords.c)), pos=1)
    else assign(".likGRF.dists.vec", as.vector(dist(coords.c)), where=1)
  }
  ##
  ## Box-Cox transformation
  ##
  if(!ip$f.lambda){
    if(round(lambda, dig=4) == 1) {
      log.jacobian <- 0
    }
    else {
      if(any(temp.list$z <= 0))
        stop("Transformation not allowed for zero or negative data")
      data <- temp.list$z^(lambda - 1)
      if(any(data <= 0)) log.jacobian <- log(prod(data))
      else log.jacobian <- sum(log(data))
      data <- NULL
    }
    if(round(lambda, dig=4) == 0)
      data <- log(temp.list$z)
    else data <- ((temp.list$z^lambda) - 1)/lambda
  }
  else data <- temp.list$z
  ##
  ## Computing likelihood
  ##
  ## NOTE: Likelihood for Independent observations 
  ##       arbitrary criteria used here:
  ##       (phi < 1-e16) or (sigmasq < 1-e16)  ==> independence
  ##
  if((phi < 1e-16) | (sigmasq < 1e-16)){
    if(ip$f.tausq)
      iv <- list(sqrt.inverse = diag(x=1/sqrt((tausq+sigmasq)), n),
                 log.det.to.half = (n/2) * log(tausq+sigmasq))
    else
      iv <- list(sqrt.inverse = diag(x=1/sqrt((1+tausq)), n),
                 log.det.to.half = (n/2) * log(1+tausq))
  }
  else{
    iv <- varcov.spatial(dists.lowertri = .likGRF.dists.vec,
                         cov.model = temp.list$cov.model, kappa=kappa,
                         nugget = tausq, cov.pars=c(sigmasq, phi),
                         sqrt.inv = TRUE, det = TRUE)
  }
  if(!is.null(iv$crash.parms)) return(.Machine$double.xmax/10000)
  sivx <- crossprod(iv$sqrt.inverse, temp.list$xmat)
  xivx <- crossprod(sivx)
  sivy <- crossprod(iv$sqrt.inverse, data)
  xivy <- crossprod(sivx, sivy)  
  betahat <- solve(xivx, xivy)
  res <- data - temp.list$xmat %*% betahat
  ssres <- as.vector(crossprod(crossprod(iv$sqrt.inverse,res)))
  if(temp.list$method == "ML"){
    if(ip$f.tausq & (tausq > 0))
      negloglik <- iv$log.det.to.half +  0.5 * ssres - log.jacobian
    else
      negloglik <- (n/2) * log(ssres) +  iv$log.det.to.half - log.jacobian
  }
  if(temp.list$method == "RML"){
    if(length(as.vector(xivx)) == 1) {
      choldet <- 0.5 * log(xivx)
    }
    else {
      chol.xivx <- chol(xivx)
      choldet <- sum(log(diag(chol.xivx)))
    }
    if(ip$f.tausq & (tausq > 0))
      negloglik <- iv$log.det.to.half +  0.5 * ssres + choldet - log.jacobian
    else
      negloglik <- ((n-p)/2) * log(ssres) +  iv$log.det.to.half +
        choldet - log.jacobian
  }  
  ##  if(negloglik > 1e64) negloglik <- 1e64
  if(negloglik > (.Machine$double.xmax/10000))
    negloglik <- (.Machine$double.xmax/10000)
  if(temp.list$print.pars)
    cat(paste("negloglik.value =", negloglik, "\n"))
  return(negloglik)
}

"boxcox.ns" <- function(lambda, bc.list)
{
  data <- bc.list$data
  n <- bc.list$n
  ##
  if(round(lambda, dig=4) == 1) {
    log.jacobian <- 0
    y <- data
  }
  else {
    if(any(data <= 0))
      stop("Transformation option not allowed when there are zeros or negative data")
    Jdata <- data^(lambda - 1)
    if(any(Jdata <= 0))
      log.jacobian <- log(prod(Jdata))
    else log.jacobian <- sum(log(Jdata))
    Jdata <- NULL
    if(is.R()) gc(verbose=FALSE)
    if(round(lambda, dig=4) == 0)
      y <- log(data)
    else y <- ((data^lambda) - 1)/lambda
  }
  beta.ns <- solve(crossprod(bc.list$xmat), crossprod(bc.list$xmat, y))
  ss.ns <- sum((as.vector(y) - as.vector(bc.list$xmat %*% beta.ns))^2)
  if(bc.list$method == "ML")
    neglik <- (n/2) * log(ss.ns) - log.jacobian
  if(bc.list$method == "RML")
    neglik <- ((n-bc.list$beta.size)/2) * log(ss.ns) - log.jacobian
  ##
  return(as.vector(neglik))
}

"likfit.limits" <-
  function(phi = c(lower=0, upper=+Inf),
           sigmasq = c(lower=0, upper=+Inf),
           tausq.rel = c(lower=0, upper=+Inf),
           kappa = c(lower=0, upper=+Inf),
           lambda = c(lower=-3, upper=3),
           psiR = c(lower=1, upper=+Inf),
           psiA = c(lower=0, upper=2*pi)
           )
{
  if(length(phi) != 2)
    stop("phi must be a 2 components vector with lower and upper limits for the parameter phi") 
  if(length(sigmasq) != 2)
    stop("phi must be a 2 components vector with lower and upper limits for the parameter phi") 
  if(length(tausq.rel) != 2)
    stop("phi must be a 2 components vector with lower and upper limits for the parameter phi") 
  if(length(kappa) != 2)
    stop("phi must be a 2 components vector with lower and upper limits for the parameter phi") 
  if(length(lambda) != 2)
    stop("phi must be a 2 components vector with lower and upper limits for the parameter phi")
  if(length(psiR) != 2)
    stop("phi must be a 2 components vector with lower and upper limits for the parameter phi") 
  if(length(psiA) != 2)
    stop("phi must be a 2 components vector with lower and upper limits for the parameter phi") 
  if(phi[1] >= phi[2])
    stop("parameter phi: lower limit greater or equal upper limit")
  if(sigmasq[1] >= sigmasq[2])
    stop("parameter sigmasq: lower limit greater or equal upper limit")
  if(tausq.rel[1] >= tausq.rel[2])
    stop("parameter tausq.rel: lower limit greater or equal upper limit")
  if(kappa[1] >= kappa[2])
    stop("parameter kappa: lower limit greater or equal upper limit")
  if(lambda[1] >= lambda[2])
    stop("parameter lambda: lower limit greater or equal upper limit")
  if(psiR[1] >= psiR[2])
    stop("parameter psiR: lower limit greater or equal upper limit")
  if(psiA[1] >= psiA[2])
    stop("parameter psiA: lower limit greater or equal upper limit")
  names(phi) <- c("lower", "upper")
  names(sigmasq) <- c("lower", "upper")
  names(tausq.rel) <- c("lower", "upper")
  names(kappa) <- c("lower", "upper")
  names(lambda) <- c("lower", "upper")
  names(psiR) <- c("lower", "upper")
  names(psiA) <- c("lower", "upper")
  return(list(phi = phi, sigmasq = sigmasq,
              tausq.rel = tausq.rel, kappa = kappa,
              lambda = lambda, psiR = psiR, psiA = psiA))
}

"print.likGRF" <-
  function(obj, digits = "default", ...)
{
  if(is.R() & digits == "default") digits <- max(3, getOption("digits") - 3)
  else digits <- options()$digits
  est.pars <- as.vector(obj$parameters.summary[obj$parameters.summary[,1] == "estimated",2])
  names.est.pars <- dimnames(obj$parameters.summary[obj$parameters.summary[,1] == "estimated",])[[1]]
  names(est.pars) <- names.est.pars
  cat("likfit: estimated model parameters:\n")
  print(round(est.pars, digits=digits))
  cat("\nlikfit: maximised log-likelihood = ")
  cat(round(obj$loglik, digits=digits))
  cat("\n")
  return(invisible())
}  

"summary.likGRF" <-
  function(obj, ...)
{
  names.pars <- dimnames(obj$parameters.summary)[[1]]
  summ.lik <- list()
  if(obj$method == "ML")
    summ.lik$method <- "maximum likelihood"
  if(obj$method == "RML")
    summ.lik$method <- "restricted maximum likelihood"
  summ.lik$mean.component <- obj$beta
  names(summ.lik$mean.component) <- names.pars[1:length(obj$beta)]
  summ.lik$cov.model <- obj$cov.model
  summ.lik$spatial.component <- obj$parameters.summary[c("sigmasq", "phi"),]
  summ.lik$spatial.component.extra <- obj$parameters.summary[c("kappa", "psiA", "psiR"),]
  summ.lik$nugget.component <- obj$parameters.summary[c("tausq"),, drop=FALSE]
  summ.lik$transformation  <- obj$parameters.summary[c("lambda"),, drop=FALSE]
  summ.lik$likelihood <- c(log.L = obj$loglik, n.params = as.integer(obj$npars),
                               AIC = obj$AIC, BIC = obj$BIC)
  summ.lik$estimated.pars <- dimnames(obj$parameters.summary[obj$parameters.summary[,1] == "estimated",])[[1]]
  likelihood.info <- c(log.L = obj$loglik, n.params = as.integer(obj$npars),
                       AIC = obj$AIC, BIC = obj$BIC)
  summ.lik$call <- obj$call
  class(summ.lik) <- "summary.likGRF"
  return(summ.lik)
}

"print.summary.likGRF" <-
  function(obj, digits = "default", ...)
{
  if(class(obj) != "summary.likGRF")
    stop("object is not of the class \"summary.likGRF\"")
  if(is.R() & digits == "default") digits <- max(3, getOption("digits") - 3)
  else digits <- options()$digits
  cat("Summary of the parameter estimation\n")
  cat("-----------------------------------\n")
  cat(paste("Estimation method:", obj$method, "\n"))
  cat("\n")
  ##
  ## Estimates of the model components
  ## Model: Y(x) = X\beta + S(x) + e 
  ##
  cat("Parameters of the mean component (trend):")
  cat("\n")
  print(round(obj$mean.component, digits=digits))
  cat("\n")
  ##
  cat("Parameters of the spatial component:")
  cat("\n")
  cat(paste("   correlation function:", obj$cov.model))
  cat(paste("\n      (estimated) variance parameter sigmasq (partial sill) = ", round(obj$spatial.component[1,2], dig=digits)))
  cat(paste("\n      (estimated) cor. fct. parameter phi (range parameter)  = ", round(obj$spatial.component[2,2], dig=digits)))
  if(obj$cov.model == "matern" | obj$cov.model == "powered.exponential" |
     obj$cov.model == "cauchy" | obj$cov.model == "gneiting.matern"){
    kappa <- obj$spatial.component.extra["kappa",2]
    if(obj$spatial.component.extra["kappa",1] == "estimated")
      cat(paste("\n      (estimated) extra parameter kappa =", round(kappa, digits=digits)))
    else{
      cat(paste("\n      (fixed) extra parameter kappa = ", kappa))
      if(obj$cov.model == "matern" & (round(kappa, digits=digits)  == 0.5))
      cat(" (exponential)")
    }
  }
  cat("\n")
  ##
  aniso <-  obj$spatial.component.extra[c("psiA", "psiR"),]
  psiApsiR <- obj$spatial.component.extra[c("psiA", "psiR"),2]
  cat("   anisotropy parameters:")
  if(aniso["psiA",1] == "estimated")
    cat(paste("\n      (estimated) anisotropy angle =",
              round(psiApsiR[1], digits=digits),
              " (",round((psiApsiR[1]*360)/(2*pi), dig=1), "degrees )"))
  else
    cat(paste("\n      (fixed) anisotropy angle =", psiApsiR[1],
              " (",(psiApsiR[1]*360)/(2*pi), "degrees )"))
  if(aniso["psiR",1] == "estimated")
    cat(paste("\n      (estimated) anisotropy ratio =",
              round(psiApsiR[2], digits=digits)))
  else
    cat(paste("\n      (fixed) anisotropy ratio =", psiApsiR[2]))
  cat("\n")
  cat("\n")  
  cat("Parameter of the error component:")
  if(obj$nugget.component[,1] == "estimated")
    cat(paste("\n      (estimated) nugget = ", round(obj$nugget.component[,2], dig=digits)))
  else
    cat(paste("\n      (fixed) nugget =", obj$nugget.component[,2]))
  cat("\n")
  cat("\n")
  cat("Transformation parameter:")
  cat("\n")
  lambda <- obj$transformation[,2]
  if(obj$transformation[,1] == "estimated")
    cat(paste("      (estimated) Box-Cox parameter =", round(lambda, dig=digits)))
  else{
    cat(paste("      (fixed) Box-Cox parameter =", lambda))
    if(lambda == 1) cat(" (no transformation)")
    if(lambda == 0) cat(" (log-transformation)")
  }
  cat("\n")
  cat("\n")
  cat("Maximised Likelihood:")
  cat("\n")
  print(round(obj$likelihood, digits=digits))
  cat("\n")
  cat("Call:")
  cat("\n")
  print(obj$call)
  cat("\n")
  invisible(obj)
}

"loglik.GRF" <-
  function(geodata, coords=geodata$coords, data=geodata$data, cov.model="exp", cov.pars, nugget=0, kappa=0.5, lambda=1, psiR=1, psiA=0, trend="cte", method="ML", compute.dists = TRUE)
{
  if(method == "REML" | method == "reml" | method == "rml") 
    method <- "RML"
  if(method == "ML" | method == "ml")
    method <- "ML"
  n <- nrow(coords)
  xmat <- trend.spatial(trend=trend, coords=coords)
  beta.size <- ncol(xmat)
  z <- data
  sigmasq <- cov.pars[1]
  phi <- cov.pars[2]
  ##
  ## Absurd values
  ##
  if(kappa < 1e-04) return(-(.Machine$double.xmax/10000))
  if(round(1e+16*(nugget+sigmasq)) == 0) return(-(.Machine$double.xmax/10000))
#  if(kappa < 1e-04) return(-1e64)
#  if(round(1e+16*(nugget+sigmasq)) == 0) return(-1e64)
  ##
  ## Anisotropy
  ##
  if(psiR != 1 | psiA != 0){
    coords.c <- coords.aniso(coords, aniso.pars=c(psiA, psiR))
    .likGRF.dists.vec <-  as.vector(dist(coords.c))
  }
  else
    if(compute.dists) .likGRF.dists.vec <-  as.vector(dist(coords))
  ##
  ## Box-Cox transformation
  ##
  if(round(lambda, dig=4) == 1) {
    log.jacobian <- 0
  }
  else {
    if(any(z <= 0))
      stop("Transformation not allowed for zero or negative data")
    data <- z^(lambda - 1)
    if(any(data <= 0)) log.jacobian <- log(prod(data))
    else log.jacobian <- sum(log(data))
    data <- NULL
    if(round(lambda, dig=4) == 0)
      data <- log(z)
    else data <- ((z^lambda) - 1)/lambda
  }
  ##
  ## Computing likelihood
  ##
  ## NOTE: Likelihood for Independent observations 
  ##       arbitrary criteria used here:
  ##       (phi < 1-e16) or (sigmasq < 1-e16)  ==> independence
  ##
  if((phi < 1e-16) | (sigmasq < 1e-16)){
    iv <- list(sqrt.inverse = diag(x=1/sqrt((nugget+sigmasq)), n),
               log.det.to.half = (n/2) * log(nugget+sigmasq))
  }
  else{
    iv <- varcov.spatial(dists.lowertri = .likGRF.dists.vec,
                         cov.model = cov.model, kappa=kappa,
                         nugget = nugget, cov.pars=c(sigmasq, phi),
                         sqrt.inv = TRUE, det = TRUE)
  }
  if(!is.null(iv$crash.parms)){
    cat("varcov.spatial: improper matrix for following the given parameters:")
    print(iv$crash.parms)
    stop()
  }
  sivx <- crossprod(iv$sqrt.inverse, xmat)
  xivx <- crossprod(sivx)
  sivy <- crossprod(iv$sqrt.inverse, data)
  xivy <- crossprod(sivx, sivy)  
  betahat <- solve(xivx, xivy)
  res <- data - xmat %*% betahat
  ssres <- as.vector(crossprod(crossprod(iv$sqrt.inverse,res)))
  if(method == "ML"){
    negloglik <- (n/2)*(log(2*pi)) + iv$log.det.to.half +  0.5 * ssres - log.jacobian
  }
  if(method == "RML"){
    if(length(as.vector(xivx)) == 1) {
      choldet <- 0.5 * log(xivx)
    }
    else {
      chol.xivx <- chol(xivx)
      choldet <- sum(log(diag(chol.xivx)))
    }
    negloglik <- iv$log.det.to.half +  0.5 * ssres + choldet - log.jacobian
    xx.eigen <- eigen(crossprod(xmat), symmetric = TRUE, only.values = TRUE)
    negloglik <- negloglik + ((n-beta.size)/2)*(log(2*pi)) - 0.5 * sum(log(xx.eigen$values))
  }
  if(negloglik > .Machine$double.xmax/10000) negloglik <- (.Machine$double.xmax/10000)
  return(-negloglik)
}



"likfit.old" <-
  function (geodata, coords=geodata$coords, data=geodata$data, trend = "cte",
            ini, fix.nugget = FALSE, nugget = 0, 
            cov.model = "matern",
            kappa = 0.5, fix.lambda = TRUE, lambda = 1, method = "ML", 
            predicted = FALSE, residuals = FALSE, 
            minimisation.function = c("optim","nlmP", "nlm"),
            automatic.refit = FALSE, range.limits,
            messages.screen = TRUE, ...) 
{
  call.fc <- match.call()
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  if (cov.model=="pure.nugget"){
    if(fix.nugget == TRUE) ini <- rep(0,2)
    else
      if(fix.nugget == TRUE) ini <- rep(0,3)
  }
  if(!is.null(kappa))
    if(cov.model == "matern" & kappa == 0.5)
      cov.model <- "exponential"
  minimisation.function <- match.arg(minimisation.function)
  if(is.R()) require(mva)
  ftau <- nugget
  fixtau <- fix.nugget
  coords <- as.matrix(coords)
  dists.vec <- as.vector(dist(coords))
  range.dist <- range(dists.vec)
  max.dist <- max(range.dist)
  min.dist <- min(range.dist)
  if(missing(range.limits)){
    lower.phi <- 0
    upper.phi <- +Inf
  }
  else{
    lower.phi <- range.limits[1]
    upper.phi <- range.limits[2]
  }
  z <- as.vector(data)
  if(fix.lambda) {
    if(lambda == 1) {
      log.jacobian <- 0
    }
    else {
      if(any(z <= 0))
        stop("Transformation option not allowed when there are zeros or negative data"
             )
      if(any(z^(lambda - 1) <= 0))
        log.jacobian <- log(prod(z^(lambda - 1)))
      else log.jacobian <- sum(log(z^(lambda - 1)))
      if(lambda == 0)
        z <- log(z)
      else z <- ((z^lambda) - 1)/lambda
    }
  }
  n <- length(z)
  if ((2*n) != length(coords))
    stop("Number of locations does not match with number of data")
  reduce.pars <- 0
  if (method == "REML" | method == "reml" | method == "rml") 
    method <- "RML"
  if(method == "ML" | method == "ml")
    method <- "ML"
  if(method == "ML" & cov.model == "power")
    stop("\n\"power\" model can only be used with method=\"RML\".\nBe sure that what you want is not \"powered.exponential\"")
  xmat <- trend.spatial(trend=trend, coords=coords)
  fit.ols <- lm(z ~ xmat + 0)
  trend.ols <- list(coefficients = fit.ols$coefficients)
  var.z <- sum((fit.ols$residual)^2)/(n-length(fit.ols$coefficients))
  dimnames(xmat) <- list(NULL, NULL)
  txmat <- t(xmat)
  beta.size <- dim(xmat)[2]  
  if(missing(ini) | ini=="default"){
    cat("likfit: no initial values for the parameters was provided. Default initial values will be used\n")
    if(fix.nugget==FALSE) ini <- c(.2*var.z, 0.8*var.z, max.dist/5)
    else ini <- c(0.8*var.z, max.dist/5)
  }    
  if(all(ini==0)){
    cov.model <- "pure.nugget"
    cat("likfit: all initial values equal to zero. Model without spatial correlation will be fitted\n")
  }
  else{
    if(is.matrix(ini)) {
      inilength <- dim(ini)[2]
      if(fixtau == FALSE & inilength != 3)
        stop("wrong number of columns for ini (must be 3)")
      if(fixtau == TRUE & inilength != 2)
        stop("wrong number of columns for ini (must be 2)")
    }
    else {
      inilength <- length(ini)
      if (fixtau == FALSE & inilength != 3) 
        stop("wrong length for ini (must be 3)")
      if (fixtau == TRUE & inilength != 2) 
        stop("wrong length for ini (must be 2)")
    }
  }
  assign(".temp.list", list(z = z, xmat = xmat,  txmat = txmat, fixtau = fixtau, 
                            ftau = ftau, method = method, kappa = kappa,
                            cov.model = cov.model, beta.size = beta.size,
                            lower.phi = lower.phi, 
                            dists.lowertri = dists.vec, var.z = var.z,
                            fix.lambda = fix.lambda, n = n,
                            minimisation.function=minimisation.function), pos=1)
  if(fix.lambda == TRUE) {
    .temp.list$lambda <<- lambda
    .temp.list$log.jacobian <<- log.jacobian
  }
  if ((cov.model == "pure.nugget") | all(ini==0) ){  
    if(messages.screen == TRUE)
      cat("likfit: fitting model without spatial correlation\n")
    lik.results <- likfit.nospatial(.temp.list, ...)
    if (fix.nugget == FALSE)
      temp.pars <- c(lik.results$tausqhat, 0, 0)
    else
      temp.pars <- c(ftau, (lik.results$tausqhat - ftau), 0)        
    lambda <- lik.results$lambda
  }
  else{
    if(is.matrix(ini) | is.data.frame(ini)) {
      ini <- as.matrix(ini)
      if(messages.screen == TRUE)
        cat("likfit: searching for the best initial value\n")
      ini.search <- ini
      if(fix.nugget == TRUE)
        ini.search <- cbind(nugget, ini.search)
      if(length(lambda) == 1)
        ini.search <- cbind(ini.search, lambda)
      else {
        temp <- ini.search
        for(i in 1:(length(lambda) - 1)) {
          ini.search <- rbind(ini.search, temp)
        }
        ini.search <- cbind(ini.search, rep(lambda, each = dim(
                                                      temp)[1]))
      }
      dimnames(ini.search) <- list(NULL, NULL)
      loglik.ini <- round(100000000. * apply(ini.search, 1, 
                                             loglik.spatial))
      ini.max <- as.vector(ini.search[loglik.ini == max(loglik.ini),
                                      ])
      if(fixtau == TRUE) {
        ini <- as.vector(ini.max[2:3])
        if(minimisation.function == "nlmP" & ini[2] == 0)
          ini[2] <- min(ini.search[(ini.search[,3] != 0),3])
      }
      else {
        ini <- as.vector(ini.max[1:3])
        if(minimisation.function == "nlmP" & ini[3] == 0)
          ini[3] <- min(ini.search[(ini.search[,3] != 0),3])
        
      }
      if(messages.screen == TRUE) {
        cat("likfit: best initial value:\n")
        names(ini.max) <- c("nugget", "sill", "range", "lambda"
                            )
        print(ini.max)
      }
      if(fix.lambda == FALSE)
        lambda <- as.vector(ini.max[4])
    }
    if (messages.screen == TRUE) {
      cat(paste("likfit: Initialising likelihood maximisation using the function", minimisation.function, "\n"))
      cat("------------------------------------------------------------\n")
      cat("likfit: consider providing additional (non-default) arguments for the minimisation function.\n")
      if(minimisation.function == "nlm" | minimisation.function == "nlmP"){
        cat("likfit: some relevant arguments are: iterlim, steptol, stepmax, print.level, ndigit. For more details see documentation for the function nlm.\n")
      }
      if(minimisation.function == "optim"){
      cat("likfit: parameters can be passed to the function optim using the argument control(). For more details see documentation for the function optim.\n")
    }
      cat("likfit: it is highly advisable to run the function several times with different initial values for the parameters (argument ini).\n")
      cat("------------------------------------------------------------\n")
      "nice" <-
        function (x, decimal = 2, fixed = FALSE) 
          {
            ergb <- x
            index <- (x != 0) & is.finite(x)
            if (fixed) 
              n <- 0
            else n <- floor(log(abs(x[index]))/log(10))
            ergb[index] <- trunc(x[index]/10^(n - decimal)) * 10^(n - decimal)
            return(ergb)
          }
      cat(paste("likfit: range of values allowed for the parameter:", nice(lower.phi), "to", nice(upper.phi), "\n"))
      cat("likfit: WARNING: This step can be time demanding!\n")
      cat("\n")
    }
    if (fixtau == FALSE | ftau != 0) {
      if (fixtau == TRUE & ftau != 0) {
                                        #        if (messages.screen == TRUE)
                                        #          print("covariance parameters used in the minimization function are $\sigma^2$ and $\phi$")
        if(minimisation.function == "nlm") assign(".temp.lower", c(0, lower.phi), pos=1)
        if(fix.lambda == TRUE) {
          assign(".temp.lower", c(0, lower.phi), pos=1)
          if(minimisation.function == "nlm"){
            lik.results <- nlm(proflik.ftau, ini, ...)
            if(exists(".temp.sill")){
              lik.results$estimate[1] <- .temp.sill
              remove(".temp.sill", pos=1)
            }
            if(exists(".temp.phi")){
              lik.results$estimate[2] <- .temp.phi
              remove(".temp.phi", pos=1)
            }
            rm(.temp.lower, inherits = TRUE, pos=1)
          }
          if(minimisation.function == "nlmP"){
            assign(".ind.prof.phi", 2, pos=1)
            lik.results <- nlmP(proflik.ftau, ini, lower=c(0, lower.phi), upper=c(10000*var.z, upper.phi), ...)
          }            
          if(minimisation.function == "optim"){
            lik.results <- optim(ini, proflik.ftau, method="L-BFGS-B", lower=c(0, lower.phi), upper=c(10000*var.z, upper.phi), ...)
            lik.results$estimate <- lik.results$par
          }            
        }
        else{
          if(minimisation.function == "nlm"){
            assign(".temp.lower", c(0, lower.phi), pos=1)
            assign(".temp.lower.lambda", -2, pos=1)
            assign(".temp.upper.lambda", 2, pos=1)
            lik.results <- nlm(proflik.ftau, c(ini,lambda), ...)
            if(exists(".temp.sill")){
              lik.results$estimate[1] <- .temp.sill
              remove(".temp.sill", pos=1)
            }
            if(exists(".temp.phi")){
              lik.results$estimate[2] <- .temp.phi
              remove(".temp.phi", pos=1)
            }
            if(exists(".temp.lambda")){
              lambda <- .temp.lambda
              remove(".temp.lambda", pos=1)
            }
            else{
              lambda <- lik.results$estimate[3]
            }
            rm(.temp.lower, .temp.lower.lambda, .temp.upper.lambda, inherits = TRUE, pos=1)
          }
          if(minimisation.function == "nlmP"){
            assign(".ind.prof.phi", 2, pos=1)
            lik.results <- nlmP(proflik.ftau, c(ini,lambda), lower = c(0, lower.phi, -2), upper = c(10000*var.z, upper.phi, 2), ...)
            lambda <- lik.results$estimate[3]
          }
          if(minimisation.function == "optim"){
            lik.results <- optim(c(ini,lambda), proflik.ftau, method="L-BFGS-B", lower = c(0, lower.phi, -2), upper = c(10000*var.z, upper.phi, 2), ...)
            lik.results$estimate <- lik.results$par              
            lambda <- lik.results$estimate[3]
          }
          lik.results$estimate <- as.vector(lik.results$estimate[1:2])
          if(lambda == 0)
            z <- log(as.vector(data))
          else z <- (((as.vector(data))^lambda) - 1)/
            lambda
        }        
        lik.results$estimate <- temp.pars <- as.vector(c(ftau, lik.results$estimate))
      }
      if (fixtau == FALSE) {
                                        #        if (messages.screen == TRUE) 
                                        #          print("parameters used in the minimization function are the ratio (tau^2/sigma^2) and $\phi$")
        ini.m <- c(ini[1]/ini[2], ini[3])
        if(fix.lambda == TRUE) {
          if (minimisation.function=="nlm"){
            assign(".temp.lower", c(0, lower.phi), pos=1)
            lik.results <- nlm(proflik.nug, ini.m, ...) 
            if(exists(".temp.nugget")){
              lik.results$estimate[1] <- .temp.nugget
              remove(".temp.nugget", pos=1)
            }
            if(exists(".temp.phi")){
              lik.results$estimate[2] <- .temp.phi
              remove(".temp.phi", pos=1)
            }
            rm(.temp.lower, inherits = TRUE, pos=1)
          }
          if (minimisation.function=="nlmP"){
            if(ini.m[1] == 0) ini.m[1] <- 0.05
            assign(".ind.prof.phi", 2, pos=1)
            lik.results <- nlmP(proflik.nug, ini.m, lower=c(0, lower.phi), upper=c(100, upper.phi),...) 
          }
          if (minimisation.function=="optim"){
            lik.results <- optim(ini.m, proflik.nug, method="L-BFGS-B", lower=c(0, lower.phi), upper=c(100, upper.phi),...) 
            lik.results$estimate <- lik.results$par              
          }
        }
        else{
          if (minimisation.function=="nlm"){
            assign(".temp.lower", c(0, lower.phi), pos=1)
            assign(".temp.lower.lambda", -2, pos=1)
            assign(".temp.upper.lambda", 2, pos=1)
            lik.results <- nlm(proflik.nug, c(ini.m, lambda), ...)
            if(exists(".temp.nugget")){
              lik.results$estimate[1] <- .temp.nugget
              remove(".temp.nugget", pos=1)
            }
            if(exists(".temp.phi")){
              lik.results$estimate[2] <- .temp.phi
              remove(".temp.phi", pos=1)
            }
            if(exists(".temp.lambda")){
              lambda <- .temp.lambda
              remove(".temp.lambda", pos=1)
            }
            else{
              lambda <- lik.results$estimate[3]
            }
            rm(.temp.lower, .temp.lower.lambda,  .temp.upper.lambda, inherits = TRUE, pos=1)
          }
          if (minimisation.function=="nlmP"){
            assign(".ind.prof.phi", 2, pos=1)
            lik.results <- nlmP(proflik.nug, c(ini.m, lambda), lower=c(0, lower.phi, -2), upper=c(100, upper.phi, 2),...)
            lambda <- lik.results$estimate[3]
          }
          if (minimisation.function=="optim"){
            lik.results <- optim(c(ini.m, lambda), proflik.nug, method="L-BFGS-B", lower=c(0, lower.phi, -2), upper=c(100, upper.phi, 2),...)
            lik.results$estimate <- lik.results$par              
            lambda <- lik.results$estimate[3]
          }            
          lik.results$estimate <- as.vector(lik.results$estimate[1:2])
          if(lambda == 0)
            z <- log(as.vector(data))
          else z <- (((as.vector(data))^lambda) - 1)/
            lambda
        }
        if(messages.screen == TRUE) {
          if(minimisation.function == "nlm" | minimisation.function == "nlmP") 
          if(minimisation.function == "optim") cat(paste("likfit: optim convergence code: ",lik.results$convergence, "\n"))
        }
        if(automatic.refit == TRUE & (lik.results$estimate[1] < 0.01)) {
          if (messages.screen == TRUE)
            cat(paste("likfit: WARNING: ratio of estimates tau^2/sigma^2 < 0.01 (",round(lik.results$estimate[1], dig = 4), ")", sep = ""))
          cat("\n")
          reduce.pars <- 1
          .temp.list$ftau <<- 0
          .temp.list$fixtau <<- T
          if(fix.lambda == TRUE) {
            if (minimisation.function=="nlm"){
              assign(".temp.lower.phi", lower.phi, pos=1)
              lik.results <- nlm(proflik.phi, ini[3],  ...)
              if(exists(".temp.phi")){
                lik.results$estimate <- .temp.phi
                remove(".temp.phi", pos=1)
              }
              rm(.temp.lower, inherits = TRUE, pos=1)
            }
            if (minimisation.function=="nlmP"){
              assign(".ind.prof.phi", 1, pos=1)
              lik.results <- nlmP(proflik.phi, ini[3],  lower=lower.phi, upper=upper.phi,...)
            }
            if (minimisation.function=="optim"){
              lik.results <- optim(ini[3], proflik.phi, method="L-BFGS-B",  lower=lower.phi, upper=upper.phi,...)
              lik.results$estimate <- lik.results$par  
            }
          }
          else {
            if (minimisation.function=="nlm"){
              assign(".temp.lower.phi", lower.phi, pos=1)
              assign(".temp.lower.lambda", -2, pos=1)
              assign(".temp.upper.lambda", 2, pos=1)
              lik.results <- nlm(proflik.phi, c(ini[3], lambda), ...)
              if(exists(".temp.lambda")){
                lambda <- .temp.lambda
                remove(".temp.lambda", pos=1)
              }
              else{
                lambda <- lik.results$estimate[2]
              }
              if(exists(".temp.phi")){
                lik.results$estimate <- .temp.phi
                remove(".temp.phi", pos=1)
              }
              else{
                lik.results$estimate <- as.vector(lik.results$estimate[1])
              }
              rm(.temp.lower.phi, .temp.lower.lambda, .temp.upper.lambda, inherits = TRUE, pos=1)
            }
            if (minimisation.function=="nlmP"){
              lik.results <- nlmP(proflik.phi, c(ini[3], lambda), lower=c(lower.phi, -2), upper=c(upper.phi, 2),...)
              lambda <- lik.results$estimate[2]
              lik.results$estimate <- lik.results$estimate[1]
            }
            if (minimisation.function=="optim"){
              lik.results <- optim(c(ini[3], lambda), proflik.phi, method="L-BFGS-B", lower=c(lower.phi, -2), upper=c(upper.phi, 2),...)
              lik.results$estimate <- lik.results$par  
              lambda <- lik.results$estimate[2]
              lik.results$estimate <- lik.results$estimate[1]
            }
            if(lambda == 0)
              z <- log(as.vector(data))
            else z <- (((as.vector(data))^lambda) -
                       1)/lambda
          }
          if (messages.screen == TRUE)        
            cat("likfit: model re-fitted without nugget effect (tausq = 0)\n")
          lik.results$estimate <- as.vector(c(0, lik.results$estimate))
          if(messages.screen == TRUE) {
            if(minimisation.function == "nlm" | minimisation.function == "nlmP") cat(paste("likfit: nlm optimisation code: ",lik.results$code,"\n"))
            if(minimisation.function == "optim") cat(paste("likfit: optim convergence code: ",lik.results$convergence,"\n"))
          }
        }          
        nugget.rel <- lik.results$estimate[1]
        if (lik.results$estimate[2] < 1e-08)
          icovhat <- diag(n)
        else
          icovhat <- varcov.spatial(coords = coords, cov.model = 
                                    cov.model, kappa = kappa, nugget = nugget.rel,
                                    cov.pars = c(1, lik.results$estimate[
                                      2]), inv = TRUE, det = FALSE)$inverse
        txiv <- crossprod(xmat, icovhat)
        sigmasqhat <- (z %*% (icovhat - crossprod(txiv,solve(txiv %*% xmat)) %*% txiv) %*% z)/n
        if(method == "RML") sigmasqhat <- sigmasqhat * n/(n-beta.size)
        nuggethat <- lik.results$estimate[1] * sigmasqhat
        lik.results$estimate <- temp.pars <- as.vector(c(nuggethat, sigmasqhat, lik.results$estimate[2]))
      }
      lik.results$estimate <- as.vector(lik.results$estimate)
      if((automatic.refit == TRUE & (lik.results$estimate[3] <= lower.phi)) | lik.results$estimate[3] < 1e-12) {
        if (messages.screen == TRUE){
          cat("likfit: WARNING: phi estimate < minimum value allowed\n")
          cat("likfit: model re-fitted without spatial correlation (phi=0)\n")
        }
        reduce.pars <- 2
        lik.results <- likfit.nospatial(.temp.list, ...)
        lambda <- lik.results$lambda
        if(fix.nugget == TRUE) {
          lik.results$parameters <- temp.pars <-
            as.vector(c(ftau, (lik.results$tausqhat - ftau), 0))
        }
        else {
          lik.results$parameters <- temp.pars <-
            as.vector(c(lik.results$tausqhat, 0, 0))
        }
      }
    }
    else {
                                        # case 3: parameters = $(\sigma^2, \phi)$ ; fixed nugget: tau^2= 0$
      ini.m <- ini[2]
      if(fix.lambda == TRUE) {
        if (minimisation.function=="nlm"){
          assign(".temp.lower.phi", lower.phi, pos=1)
          lik.results <- nlm(proflik.phi,ini.m,   ...)
          if(exists(".temp.phi")){
            lik.results$estimate <- .temp.phi
            remove(".temp.phi", pos=1)
          }
          rm(.temp.lower, inherits = TRUE, pos=1)
        }
        if (minimisation.function=="nlmP"){
          assign(".ind.prof.phi", 1, pos=1)
          lik.results <- nlmP(proflik.phi,ini.m, lower=lower.phi, upper=upper.phi,...)
        }
        if (minimisation.function=="optim"){
          lik.results <- optim(ini.m, proflik.phi, method="L-BFGS-B", lower=lower.phi, upper=upper.phi,...)
          lik.results$estimate <- lik.results$par
        }
      }
      else {
        if (minimisation.function=="nlm"){
          assign(".temp.lower.phi", lower.phi, pos=1)
          assign(".temp.lower.lambda", -2, pos=1)
          assign(".temp.upper.lambda", 2, pos=1)
          lik.results <- nlm(proflik.phi, c(ini.m, lambda), ...)
          if(exists(".temp.lambda")){
            lambda <- .temp.lambda
            remove(".temp.lambda", pos=1)
          }
          else{
            lambda <- lik.results$estimate[2]
          }
          if(exists(".temp.phi")){
            lik.results$estimate <- .temp.phi
            remove(".temp.phi", pos=1)
          }
          else{
            lik.results$estimate <- as.vector(lik.results$estimate[1])
          }
          rm(.temp.lower.phi, .temp.lower.lambda, .temp.upper.lambda, inherits = TRUE, pos=1)
        }
        if (minimisation.function=="nlmP"){
          assign(".ind.prof.phi", 1, pos=1)
          lik.results <- nlmP(proflik.phi, c(ini.m, lambda), lower=c(lower.phi, -2), upper=c(upper.phi, 2),...)
          lambda <- as.vector(lik.results$estimate[2])
          lik.results$estimate <- as.vector(lik.results$estimate[1])
        }
        if (minimisation.function=="optim"){
          lik.results <- optim(c(ini.m, lambda), proflik.phi, method="L-BFGS-B", lower=c(lower.phi, -2.5), upper=c(upper.phi, 2.5),...)
          lik.results$estimate <- lik.results$par        
          lambda <- as.vector(lik.results$estimate[2])
          lik.results$estimate <- as.vector(lik.results$estimate[1])
        }
        if(lambda == 0)
          z <- log(as.vector(data))
        else z <- (((as.vector(data))^lambda) - 1)/lambda
      }    
      if(messages.screen == TRUE) {
        if(minimisation.function == "nlm" | minimisation.function == "nlmP")
          cat(paste("likfit: nlm optimisation code: ",lik.results$code, "\n"))
        if(minimisation.function == "optim") cat(paste("likfit: optim convergence code: ",lik.results$convergence, "\n"))
      }      
      if(automatic.refit == TRUE & (lik.results$estimate <= lower.phi)) {
        if (messages.screen == TRUE) {
          cat("likfit: WARNING: phi estimate < minimum value allowed\n")
          cat("likfit: model without spatial correlation was fitted (phi=0 and sigma^2=0)\n")
        }
        reduce.pars <- 1
        lik.results <- likfit.nospatial(.temp.list, ...)
        lambda <- lik.results$lambda
        if(fix.nugget == TRUE) {
          lik.results$parameters <- temp.pars <-
            as.vector(c(ftau, (lik.results$tausqhat - ftau), 0))
        }
        else {
          lik.results$parameters <- temp.pars <-
            as.vector(c(lik.results$tausqhat, 0, 0))
        }
      }
      else {
        if(lik.results$estimate < 1e-08)
          icovhat <- diag(n)
        else
          icovhat <- varcov.spatial(coords = coords, cov.model = 
                                    cov.model, kappa = kappa,
                                    nugget = 0, cov.pars
                                    = c(1, lik.results$estimate),
                                    inv = TRUE, det = FALSE)$inverse
        txiv <- crossprod(xmat, icovhat)
        sigmasqhat <- (z %*% (icovhat - crossprod(txiv, solve(txiv %*% xmat
                                                              ) %*% txiv)) %*% z)/n
        if(method == "RML") sigmasqhat <- sigmasqhat * n/(n-beta.size)
        temp.pars <- as.vector(c(0, sigmasqhat, lik.results$estimate))
        lik.results$estimate <- as.vector(c(0,sigmasqhat, lik.results$estimate))
      }
    }
  }
  if(messages.screen == TRUE) {
    cat("likfit: end of likelihood maximisation\n")
  }
  if(any(temp.pars < 0)){
    temp.pars <- round(temp.pars, dig=14)
    lik.results$estimate <- round(lik.results$estimate, dig=14)
  }
  if(minimisation.function == "optim") lik.results$minimum <- lik.results$value
  loglik <- -lik.results$minimum
  npars <- length(trend.ols$coefficients) + length(ini) - reduce.pars
  if (fix.lambda == FALSE) npars <- npars + 1
  AIC <- loglik - npars
  BIC <- loglik - 0.5 * log(n) * npars
  if (messages.screen == TRUE) 
    cat("likfit: computing the beta estimate\n")
  if(any(temp.pars[2:3]) != 0)
    invcov <- varcov.spatial(coords = coords, cov.model = cov.model, 
                             kappa = kappa, nugget = temp.pars[1],
                             cov.pars = temp.pars[2:3], 
                             inv = TRUE, det = FALSE)$inverse
  else invcov <- diag((1/temp.pars[1]), n)
  txmatinvcov <- crossprod(xmat, invcov)
  beta <- solve(txmatinvcov %*% xmat) %*% txmatinvcov %*% z
  beta.var <- solve(txmatinvcov %*% xmat)
  if (residuals == TRUE | predicted == TRUE) {
    cat("likfit: computing predicted values and residuals\n")
    trend.est <- as.vector(xmat %*% beta)
    residuals.trend <- as.vector(z - trend.est)
    covmat.signal <- varcov.spatial(coords = coords, cov.model = cov.model, 
                                    kappa = kappa, nugget = 0,
                                    cov.pars = temp.pars[2:3])$varcov
    signal.est <- as.vector(covmat.signal %*% invcov %*% 
                            residuals.trend)
    predict.est <- trend.est + signal.est
    residuals.est <- as.vector(z - predict.est)
    residuals.std <- as.vector(invcov %*% residuals.est)
    residuals.trend.std <- as.vector(invcov %*% residuals.trend)
    s2.trend <- (crossprod(residuals.trend,invcov) %*% residuals.trend)/(n - 
                                                                         length(beta))
    s2 <- (crossprod(residuals.est,invcov) %*% residuals.est)/(n - 
                                                               length(beta))
  }
  if (messages.screen == TRUE) 
    cat("likfit: preparing output\n")
  results <- list()
  results$cov.model <- cov.model
  results$nugget <- temp.pars[1]
  results$cov.pars <- as.vector(c(sigmasq = temp.pars[2], phi = temp.pars[3]))
  if (is.null(kappa))
    results$kappa <- "not used"
  else
    results$kappa <- kappa
  results$beta <- as.vector(beta)
  results$beta.var <- beta.var
  if (length(results$beta.var) == 1)
    results$beta.var <- as.vector(results$beta.var)
  if (length(results$beta) > 1){
    if(inherits(trend, "formula"))
      beta.names <- c("intercept", paste("covar", 1:(ncol(xmat)-1), sep = ""))
    else
      if (trend == "1st")
        beta.names <- c("1", "x", "y")
      else
        if (trend == "2nd")
          beta.names <- c("1", "x", "y", "x2", "xy", "y2")
    names(results$beta) <- beta.names
  }
  results$lambda <- lambda
  results$loglik <- loglik
  results$npars <- npars
  results$AIC <- AIC
  results$BIC <- BIC
  results$trend.ols <- as.vector(trend.ols$coefficients)
  names(results$trend.ols) <- names(results$beta)
  if (residuals == TRUE) {
    results$s2 <- s2
    results$s2.trend <- s2.trend
  }
  if (predicted == TRUE) 
    results$predicted <- cbind(predicted = predict.est, trend.est = trend.est, 
                               signal.est = signal.est)
  if (residuals == TRUE) 
    results$residuals <- round(cbind(residuals = residuals.est, 
                                     resid.trend = residuals.trend, resid.std = residuals.std, 
                                     resid.trend.std = residuals.trend.std), dig = 12)
  if(fix.lambda == FALSE) {
    if(lambda == 1) {
      log.jacobian <- 0
    }
    else {
      if(any(data^(lambda - 1) <= 0))
        log.jacobian <- log(prod(data^(lambda - 1)))
      else log.jacobian <- sum(log(data^(lambda - 1)))
    }
  }
  results$info.lambda <- list(fix.lambda = fix.lambda, log.jacobian = 
                              log.jacobian)
  lik.results$estimate <- NULL
  lik.results$aux <- NULL
  lik.results$minimum <- NULL
  results$method <- method
  results$info <- lik.results
  results$max.dist <- max.dist
  results$trend.matrix <- xmat
  results$call <- call.fc
  class(results) <- "variomodel"
  if(messages.screen == TRUE){
    cat("likfit: estimated model parameters are:\n")
    cat(paste("covariance model:", cov.model))
    if(cov.model == "matern" | cov.model == "powered.exponential" | 
       cov.model == "cauchy" | cov.model == "gneiting.matern")
      cat(paste(" with kappa =", kappa))
    if(!is.null(kappa))
      if(cov.model == "matern" & kappa == 0.5)
        cat(" (exponential)")
    cat("\n")
    print(c(nugget=results$nugget, sill=results$cov.pars[1], range=results$cov.pars[2]))
    if (fix.lambda == FALSE)
      cat(paste("Box-Cox transformation parameter:", round(results$lambda, dig=4),"\n"))
    if((results$cov.pars[1] < (0.01 * (results$nugget + results$cov.pars[1])))& results$cov.pars[2] > 0)
      cat("\nWARNING: estimated sill is less than 1 hundredth of the total variance. Consider re-examine the model excluding spatial dependence\n" )      
    if((results$cov.pars[2] > (10 * max.dist)) & results$cov.pars[1] > 0 )
      cat("\nWARNING: estimated range is more than 10 times bigger than the biggest distance between two points. Consider re-examine the model:\n 1) excluding spatial dependence if estimated sill is too low and/or \n 2) taking trends (covariates) into account\n" ) 
    if(((results$cov.pars[2] < (0.1 * min.dist)) & (results$cov.pars[1] > 0)) & results$cov.pars[2] > 0)
      cat("\nWARNING: estimated range is less than 1 tenth of the minimum distance between two points. Consider re-examine the model excluding spatial dependence\n" ) 
  }
  remove(".temp.list", pos=1)
  return(results)
}

"proflik.ftau" <-
  function (theta) 
{
  if (any(is.na(theta)) | any(theta==Inf) | any(is.nan(theta)))
    neglik <- 1e+32
  else{
    if(length(theta) == 3) include.lambda <- TRUE else include.lambda <- FALSE 
    if(.temp.list$minimisation.function == "nlm"){
      if (exists(".temp.phi", w=1)) remove(".temp.phi", pos=1, inherits = TRUE)
      if (exists(".temp.lambda", w=1)) remove(".temp.lambda", pos=1, inherits = TRUE)
      if (exists(".temp.sill", w=1)) remove(".temp.sill", pos=1, inherits = TRUE)
      theta.minimiser <- theta
      penalty <- 10000 * sum(.temp.lower - pmin(theta[1:2], .temp.lower))
      theta[1:2] <- pmax(theta[1:2], .temp.lower)
      if (theta.minimiser[1] <  .temp.lower[1])
        assign(".temp.sill", theta[1], pos=1)
      if (theta.minimiser[2] < 1.001 * .temp.lower[2])
        assign(".temp.phi", theta[2], pos=1)
      if (include.lambda){
        lambda <- theta[3]
        penalty <- penalty + 1000 * (.temp.lower.lambda - min(lambda, .temp.lower.lambda))
        lambda <- max(lambda, .temp.lower.lambda)
        penalty <- penalty + 1000 * (.temp.upper.lambda - max(lambda, .temp.upper.lambda))
        lambda <- min(lambda, .temp.upper.lambda)
        if (round(1000 * theta.minimiser[3]) <= round(1000 * .temp.lower.lambda))
          assign(".temp.lambda", lambda, pos=1)
        if (round(1000 * theta.minimiser[3]) >= round(1000 * .temp.upper.lambda))
          assign(".temp.lambda", lambda, pos=1)
      }
    }
    else{
      if (include.lambda) lambda <- theta[3]
    }
    z <- .temp.list$z
    n <- length(z)
    if (include.lambda){
      if(lambda == 1) {
        .temp.list$log.jacobian <<- 0
      }
      else {
        if(any(z < 0))
          stop("Transformation option not allowed when there are zeros or negative data"
               )
        if(any(z^(lambda - 1) <= 0))
          .temp.list$log.jacobian <<- log(prod(z^(lambda - 1)))
        else .temp.list$log.jacobian <<- sum(log(z^(lambda - 1)))
        if(lambda == 0)
          z <- log(z)
        else z <- ((z^lambda) - 1)/lambda
      }
    }
    beta.size <- .temp.list$beta.size
    kappa <- .temp.list$kappa
    ftau <- .temp.list$ftau
    sigmasq <- theta[1]
    sill.total <- ftau + sigmasq
    phi <- theta[2]
    covinf <- varcov.spatial(dists.lowertri = .temp.list$dists.lowertri,
                             cov.model = .temp.list$cov.model, kappa = kappa, 
                             nugget = ftau, cov.pars = c(sigmasq, phi), 
                             det = TRUE, func.inv = "eigen",
                             only.inv.lower.diag = TRUE)
    xix <- as.double(rep(0, beta.size*beta.size))
    xix <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(.temp.list$xmat)),
              as.double(as.vector(.temp.list$xmat)),
              as.integer(beta.size),
              as.integer(beta.size),
              as.integer(n),
              res = xix)$res
    attr(xix, "dim") <- c(beta.size, beta.size)
    if(length(as.vector(xix)) == 1) {
      ixix <- 1/xix
      choldet <- 0.5 * log(xix)
    }
    else {
      chol.xix <- chol(xix)
      ixix <- chol2inv(chol.xix)
      choldet <- sum(log(diag(chol.xix)))
    }
    xiy <- as.double(rep(0, beta.size))
    xiy <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(.temp.list$xmat)),
              as.double(as.vector(z)),
              as.integer(beta.size),
              as.integer(1),
              as.integer(n),
              res = xiy)$res
    beta.hat <- as.vector(ixix %*% xiy)
    yiy <- as.double(0.0)
    yiy <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(z)),
              as.double(as.vector(z)),
              as.integer(1),
              as.integer(1),
              as.integer(n),
              res = yiy)$res
    ssresmat <- as.vector(yiy - crossprod(beta.hat,xiy))
    if(.temp.list$method == "ML") {
      neglik <- ((n/2) * log(2 * pi) +
                 covinf$log.det.to.half +
                 0.5 * ssresmat -
                 .temp.list$log.jacobian
                 )
    }
    if(.temp.list$method == "RML") {
      xx.eigen <- eigen(crossprod(.temp.list$xmat), symmetric = TRUE, only.values = TRUE)
      neglik <- (((n - beta.size)/2) * log(2 * pi) +
                 covinf$log.det.to.half +
                 0.5 * ssresmat +
                 choldet -
                 0.5 * sum(log(xx.eigen$values)) -
                 .temp.list$log.jacobian
                 )
    }
  }
  if(.temp.list$minimisation.function == "nlm")
    return(as.vector(neglik + penalty))
  else
    return(as.vector(neglik))
}
"proflik.lambda" <-
function(lambda)
{
  if (any(is.na(lambda)) | any(lambda==Inf) | any(is.nan(lambda)))
    neglik <- 1e+32
  else{
    if(.temp.list$minimisation.function == "nlm"){
      if (exists(".temp.lambda", w=1)) remove(".temp.lambda", pos=1, inherits = TRUE)
      lambda.minimiser <- lambda
      penalty <-  1000 * (.temp.lower.lambda - min(lambda, .temp.lower.lambda))
      lambda <- max(lambda, .temp.lower.lambda)
      penalty <- penalty + 1000 * (.temp.upper.lambda - max(lambda, .temp.upper.lambda))
      lambda <- min(lambda, .temp.upper.lambda)
      if (round(1000 * lambda.minimiser) <= round(1000 * .temp.lower.lambda))
        assign(".temp.lambda", lambda, pos=1)
      if (round(1000 * lambda.minimiser) >= round(1000 * .temp.upper.lambda))
        assign(".temp.lambda", lambda, pos=1)
    }
    z <- .temp.list$z
    n <- .temp.list$n
    if(lambda == 1) {
      .temp.list$log.jacobian <- 0
    }
    else {
      if(any(z < 0))
        stop("Transformation option not allowed when there are zeros or negative data"
             )
      if(any(z^(lambda - 1) <= 0))
        .temp.list$log.jacobian <- log(prod(z^(lambda - 1)))
      else .temp.list$log.jacobian <- sum(log(z^(lambda - 1)))
      if(lambda == 0)
        z <- log(z)
      else z <- ((z^lambda) - 1)/lambda
    }
    beta.size <- .temp.list$beta.size
    kappa <- .temp.list$kappa
    xmat <- .temp.list$xmat
    txmat <- .temp.list$txmat
    ixx <- solve(crossprod(xmat))
    tausqhat <- (z %*% (diag(n) - xmat %*% ixx %*% txmat) %*% z)/n
    if(.temp.list$method == "ML")
      neglik <- ((n/2) * log(2 * pi) +
                 (n/2) * log(tausqhat) +
                 (n/2) -
                 .temp.list$log.jacobian
                 )
    if(.temp.list$method == "RML") {
      eigentrem <- eigen(ixx, symmetric = TRUE, only.values = TRUE)
      neglik <- (((n - beta.size)/2) * log(2 * pi) +
                 ((n - beta.size)/2) * log(tausqhat) +
                 (n/2) -
                 0.5 * sum(log(eigentrem$values)) -
                 .temp.list$log.jacobian
                 )
    }
  }
  if(.temp.list$minimisation.function == "nlm")
    return(as.vector(neglik + penalty))
  else
    return(as.vector(neglik))
}

"proflik.nug" <-
  function (theta) 
{
  if (any(is.na(theta)) | any(theta==Inf) | any(is.nan(theta)))
    neglik <- 1e+32
  else{
    if(length(theta) == 3) include.lambda <- TRUE else include.lambda <- FALSE 
    if(.temp.list$minimisation.function == "nlm"){
      if (exists(".temp.phi", w=1)) remove(".temp.phi", pos=1, inherits = TRUE)
      if (exists(".temp.lambda", w=1)) remove(".temp.lambda", pos=1, inherits = TRUE)
      if (exists(".temp.nugget", w=1)) remove(".temp.nugget", pos=1, inherits = TRUE)
      theta.minimiser <- theta
      penalty <- 10000 * sum(.temp.lower - pmin(theta[1:2], .temp.lower))
      theta[1:2] <- pmax(theta[1:2], .temp.lower)
      if (theta.minimiser[1] <  .temp.lower[1])
        assign(".temp.nugget", theta[1], pos=1)
      if (theta.minimiser[2] < 1.001 * .temp.lower[2])
        assign(".temp.phi", theta[2], pos=1)
      if (include.lambda){
        lambda <- theta[3]
        penalty <- penalty + 1000 * (.temp.lower.lambda - min(lambda, .temp.lower.lambda))
        lambda <- max(lambda, .temp.lower.lambda)
        penalty <- penalty + 1000 * (.temp.upper.lambda - max(lambda, .temp.upper.lambda))
        lambda <- min(lambda, .temp.upper.lambda)
        if (round(1000 * theta.minimiser[3]) <= round(1000 * .temp.lower.lambda))
          assign(".temp.lambda", lambda, pos=1)
        if (round(1000 * theta.minimiser[3]) >= round(1000 * .temp.upper.lambda))
          assign(".temp.lambda", lambda, pos=1)
      }
    }
    else{
      if(include.lambda) lambda <- theta[3]
    }
    z <- .temp.list$z
    n <- .temp.list$n
    if(include.lambda){
      if(lambda == 1) {
        .temp.list$log.jacobian <<- 0
      }
      else {
        if(any(z < 0))
          stop("Transformation option not allowed when there are zeros or negative data"
               )
        if(any(z^(lambda - 1) <= 0))
          .temp.list$log.jacobian <<- log(prod(z^(lambda - 1)))
        else .temp.list$log.jacobian <<- sum(log(z^(lambda - 1)))
        if(lambda == 0)
          z <- log(z)
        else z <- ((z^lambda) - 1)/lambda
      }
    }
    beta.size <- .temp.list$beta.size
    kappa <- .temp.list$kappa
    tausq.rel <- theta[1]
    phi <- theta[2]
    covinf <- varcov.spatial(dists.lowertri = .temp.list$dists.lowertri,
                             cov.model = .temp.list$cov.model, kappa = kappa,
                             nugget = tausq.rel, cov.pars = c(1, phi),
                             det = TRUE, func.inv = "eigen",
                             only.inv.lower.diag = TRUE)
    xix <- as.double(rep(0, beta.size*beta.size))
    xix <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(.temp.list$xmat)),
              as.double(as.vector(.temp.list$xmat)),
              as.integer(beta.size),
              as.integer(beta.size),
              as.integer(n),
              res = xix)$res
    attr(xix, "dim") <- c(beta.size, beta.size)
    if(length(as.vector(xix)) == 1) {
      ixix <- 1/xix
      choldet <- 0.5 * log(xix)
    }
    else {
      chol.xix <- chol(xix)
      ixix <- chol2inv(chol.xix)
      choldet <- sum(log(diag(chol.xix)))
    }
    xiy <- as.double(rep(0, beta.size))
    xiy <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(.temp.list$xmat)),
              as.double(as.vector(z)),
              as.integer(beta.size),
              as.integer(1),
              as.integer(n),
              res = xiy)$res
    beta.hat <- as.vector(ixix %*% xiy)
    yiy <- as.double(0.0)
    yiy <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(z)),
              as.double(as.vector(z)),
              as.integer(1),
              as.integer(1),
              as.integer(n),
              res = yiy)$res
    ssresmat <- as.vector(yiy - crossprod(beta.hat,xiy))
    if(.temp.list$method == "ML") {
      neglik <- ((n/2) * log(2 * pi) +
                 covinf$log.det.to.half +
                 (n/2) * log(ssresmat/n) +
                 (n/2) -
                 .temp.list$log.jacobian
                 )
    }
    if(.temp.list$method == "RML") {
      xx.eigen <- eigen(crossprod(.temp.list$xmat), symmetric = TRUE, only.values = TRUE)
      neglik <- (((n - beta.size)/2) * log(2 * pi) +
                 covinf$log.det.to.half +
                 ((n - beta.size)/2) * log(ssresmat/(n-beta.size)) +
                 (n/2) +
                 choldet -
                 0.5 * sum(log(xx.eigen$values)) -
                 .temp.list$log.jacobian
                 )
    }
  }
  if(.temp.list$minimisation.function == "nlm")
    return(as.vector(neglik + penalty))
  else
    return(as.vector(neglik))
}

"proflik.phi" <-
  function (theta) 
{
  if (any(is.na(theta)) | any(theta==Inf) | any(is.nan(theta)))
    neglik <- 1e+32
  else{
    if(length(theta) == 2) include.lambda <- TRUE else include.lambda <- FALSE 
    if(.temp.list$minimisation.function == "nlm"){
      if (exists(".temp.phi", w=1)) remove(".temp.phi", pos=1, inherits = TRUE)
      if (exists(".temp.lambda", w=1)) remove(".temp.lambda", pos=1, inherits = TRUE)
      phi <- phi.minimiser <- theta[1]
      penalty <-  100000 * (.temp.lower.phi - min(phi, .temp.lower.phi))
      phi <- max(phi, .temp.lower.phi)
      if (phi.minimiser < 1.001 * .temp.lower.phi)
        assign(".temp.phi", phi, pos=1)
      if(include.lambda){
        lambda <- lambda.minimiser <- phi.lambda[2]
        penalty <-  penalty + 1000 * (.temp.lower.lambda - min(lambda, .temp.lower.lambda))
        lambda <- max(lambda, .temp.lower.lambda)
        penalty <- penalty + 1000 * (.temp.upper.lambda - max(lambda, .temp.upper.lambda))
        lambda <- min(lambda, .temp.upper.lambda)
        if (round(1000 * lambda.minimiser) <= round(1000 * .temp.lower.lambda))
          assign(".temp.lambda", lambda, pos=1)
        if (round(1000 * lambda.minimiser) >= round(1000 * .temp.upper.lambda))
          assign(".temp.lambda", lambda, pos=1)
      }
    }
    else{
      phi <- theta[1]
      if(include.lambda) lambda <- theta[2]
    }
    z <- .temp.list$z
    n <- .temp.list$n
    if(include.lambda){
      if(lambda == 1) {
        .temp.list$log.jacobian <<- 0
      }
      else {
        if(any(z <= 0))
          stop("Transformation option not allowed when there are zeros or negative data"
               )
        if(any(z^(lambda - 1) <= 0))
          .temp.list$log.jacobian <<- log(prod(z^(lambda - 1)))
        else .temp.list$log.jacobian <<- sum(log(z^(lambda - 1)))
        if(lambda == 0)
          z <- log(z)
        else z <- ((z^lambda) - 1)/lambda
      }
    }
    beta.size <- .temp.list$beta.size
    kappa <- .temp.list$kappa
    covinf <- varcov.spatial(dists.lowertri = .temp.list$
                             dists.lowertri,
                             cov.model = .temp.list$cov.model,
                             kappa = kappa, nugget = 0,
                             cov.pars = c(1, phi),
                             det = TRUE, func.inv = "eigen",
                             only.inv.lower.diag = TRUE)
    xix <- as.double(rep(0, beta.size*beta.size))
    xix <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(.temp.list$xmat)),
              as.double(as.vector(.temp.list$xmat)),
              as.integer(beta.size),
              as.integer(beta.size),
              as.integer(n),
              res = xix)$res
    attr(xix, "dim") <- c(beta.size, beta.size)
    if(length(as.vector(xix)) == 1) {
      ixix <- 1/xix
      choldet <- 0.5 * log(xix)
    }
    else {
      chol.xix <- chol(xix)
      ixix <- chol2inv(chol.xix)
      choldet <- sum(log(diag(chol.xix)))
    }
    xiy <- as.double(rep(0, beta.size))
    xiy <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(.temp.list$xmat)),
              as.double(as.vector(z)),
              as.integer(beta.size),
              as.integer(1),
              as.integer(n),
              res = xiy)$res
    beta.hat <- as.vector(ixix %*% xiy)
    yiy <- as.double(0.0)
    yiy <- .C("bilinearform_XAY",
              as.double(covinf$lower.inverse),
              as.double(covinf$diag.inverse),
              as.double(as.vector(z)),
              as.double(as.vector(z)),
              as.integer(1),
              as.integer(1),
              as.integer(n),
              res = yiy)$res
    ssresmat <- as.vector(yiy - crossprod(beta.hat,xiy))
    if(.temp.list$method == "ML") {
      neglik <- ((n/2) * log(2 * pi) + covinf$log.det.to.half +
                 (n/2) * log(ssresmat/n) + (n/2)) - .temp.list$
      log.jacobian
    }
    if(.temp.list$method == "RML") {
      xx.eigen <- eigen(crossprod(.temp.list$xmat), symmetric = TRUE, only.values = TRUE)
      neglik <- (((n - beta.size)/2) * log(2 * pi) +
                 covinf$log.det.to.half +
                 ((n - beta.size)/2) * log(ssresmat/(n-beta.size)) +
                 (n/2) +
                 choldet -
                 0.5 * sum(log(xx.eigen$values)) -
                 .temp.list$log.jacobian
                 )
    }
  }
  if(.temp.list$minimisation.function == "nlm")
    return(as.vector(neglik + penalty))
  else
    return(as.vector(neglik))
}








"proflik" <- 
  function(obj.likfit, geodata, coords = geodata$coords,
           data = geodata$data,
           sill.values,
           range.values, 
           nugget.values,
           nugget.rel.values,
           lambda.values,
           sillrange.values = TRUE,
           sillnugget.values = TRUE,
           rangenugget.values = TRUE, 
           sillnugget.rel.values = FALSE,
           rangenugget.rel.values = FALSE, 
           silllambda.values = FALSE,
           rangelambda.values = TRUE, 
           nuggetlambda.values = FALSE,
           nugget.rellambda.values = FALSE,
           uni.only = TRUE,
           bi.only = FALSE,
           ...)
{
  ##
  ## 1. setting arguments
  ##
  require(mva)
  call.fc <- match.call()
  n.cov.pars <- obj.likfit$npars - length(obj.likfit$beta)
  if(obj.likfit$transform.info$fix.lambda == FALSE)
    n.cov.pars <- n.cov.pars - 1
  if(missing(sill.values)) sill.values <- FALSE
  if(missing(range.values)) range.values <- FALSE 
  if(!is.null(obj.likfit$call$fix.nugget))
    if(obj.likfit$call$fix.nugget == TRUE)
      nugget.values <-  nugget.rel.values <- FALSE
  if(missing(nugget.values)) nugget.values <- FALSE
  if(missing(nugget.rel.values)) nugget.rel.values <- FALSE
  if(missing(lambda.values) | obj.likfit$transform.info$fix.lambda == TRUE)
    lambda.values <- FALSE  
  if(uni.only == TRUE){
    sillrange.values <- sillnugget.values <- rangenugget.values <-
      sillnugget.rel.values <- rangenugget.rel.values <- 
        silllambda.values <- rangelambda.values <- 
          nugget.rellambda.values <- nuggetlambda.values <- FALSE
  }
  else{
    if(all(sillrange.values == TRUE)){
      if(all(sill.values == FALSE) | all(range.values == FALSE)){
        sillrange.values <- FALSE
        stop("if argument sillrange.values = TRUE sill.values and range.values must be provided. Alternatively a matrix can be provided in sillrange.values  or set this to FALSE")
      }
      else
        sillrange.values <- as.matrix(expand.grid(sill.values, range.values))
    }
    if(n.cov.pars == 2){
        sillnugget.values <- rangenugget.values <-
          sillnugget.rel.values <- rangenugget.rel.values <- 
            nugget.rellambda.values <- nuggetlambda.values <- FALSE
    }
    else{
      if(all(sillnugget.values == TRUE)){
        if(all(sill.values == FALSE) | all(nugget.values == FALSE)){
          sillnugget.values <- FALSE
          stop("if argument sillnugget.values = TRUE sill.values and nugget.values must be provided. Alternatively a matrix can be provided in sillnugget.values or set this to FALSE")
        }
        else
          sillnugget.values <- as.matrix(expand.grid(sill.values, nugget.values))
      }
      if(all(rangenugget.values == TRUE)){
        if(all(range.values == FALSE) | all(nugget.values == FALSE)){
          rangenugget.values <- FALSE
          stop("if argument rangenugget.values = TRUE range.values and nugget.values must be provided. Alternatively a matrix can be provided in rangenugget.values or set this to FALSE")
        }
        else
          rangenugget.values <- as.matrix(expand.grid(range.values, nugget.values))
      }
      if(all(sillnugget.rel.values == TRUE)){
        if(all(sill.values == FALSE) | all(nugget.rel.values == FALSE)){
          sillnugget.rel.values <- FALSE
          stop("if argument sillnugget.rel.values = TRUE sill.values and nugget.rel.values must be provided. Alternatively a matrix can be provided in sillnugget.rel.values or set this to FALSE")
        }
        else
          sillnugget.rel.values <- as.matrix(expand.grid(sill.values, nugget.rel.values))
      }
      if(all(rangenugget.rel.values == TRUE)){
        if(all(range.values == FALSE) | all(nugget.rel.values == FALSE)){
          rangenugget.rel.values <- FALSE
          stop("if argument rangenugget.rel.values = TRUE range.values and nugget.rel.values must be provided. Alternatively a matrix can be provided in rangenugget.rel.values or set this to FALSE")
        }
        else
          rangenugget.rel.values <- as.matrix(expand.grid(range.values, nugget.rel.values))
      }
      if(obj.likfit$transform.info$fix.lambda == TRUE){
        if(all(nuggetlambda.values == TRUE)){
          if(all(lambda.values == FALSE) | all(nugget.values == FALSE)){
            nuggetlambda.values <- FALSE
            stop("if argument nuggetlambda.values = TRUE lambda.values and nugget.values must be provided. Alternatively a matrix can be provided in nuggetlambda.values or set this to FALSE")
          }
          else
            nuggetlambda.values <- as.matrix(expand.grid(lambda.values, nugget.values))
        }
        if(all(nugget.rellambda.values == TRUE)){
          if(all(lambda.values == FALSE) | all(nugget.rel.values == FALSE)){
            nugget.rellambda.values <- FALSE
            stop("if argument nugget.rellambda.values = TRUE lambda.values and nugget.rel.values must be provided. Alternatively a matrix can be provided in nugget.rellambda.values or set this to FALSE")
          }
          else
            nugget.rellambda.values <- as.matrix(expand.grid(lambda.values, nugget.rel.values))
        }
      }
    }
    if(obj.likfit$transform.info$fix.lambda == TRUE)
      silllambda.values <- rangelambda.values <- FALSE
    else{
      if(all(silllambda.values == TRUE)){
        if(all(sill.values == FALSE) | all(lambda.values == FALSE)){
          silllambda.values <- FALSE
          stop("if argument silllambda.values = TRUE sill.values and lambda.values must be provided. Alternatively a matrix can be provided in silllambda.values or set this to FALSE")
        }
        else
          silllambda.values <- as.matrix(expand.grid(sill.values, lambda.values))
      }
      if(all(rangelambda.values == TRUE)){
        if(all(range.values == FALSE) | all(lambda.values == FALSE)){
          rangelambda.values <- FALSE
          stop("if argument rangelambda.values = TRUE range.values and lambda.values must be provided. Alternatively a matrix can be provided in rangelambda.values or set this to FALSE")
        }
        else
          rangelambda.values <- as.matrix(expand.grid(range.values, lambda.values))
      }      
    }
  }
  ##
  ## 2. data preparation
  ##
  trend <- trend.spatial(trend=obj.likfit$trend, coords=coords)
  data <- as.vector(data)
  dimnames(trend) <- list(NULL, NULL)
  if(obj.likfit$transform.info$fix.lambda == TRUE) {
    if(obj.likfit$lambda != 1) {
      if(any(data <= 0))
        stop("Data transformation not allowed when there are zeros or negative data"
             )
      if(obj.likfit$lambda == 0)
        data <- log(data)
      else data <- ((data^obj.likfit$lambda) - 1)/obj.likfit$
      lambda
    }
  }
  n <- length(data)
  dists.vec <- as.vector(dist(coords))
  d <- range(dists.vec)
  min.dist <- d[1]
  max.dist <- d[2]
  tausq <- obj.likfit$nugget
  sigmasq <- obj.likfit$cov.pars[1]
  tausq.rel <- tausq/sigmasq
  phi <- obj.likfit$cov.pars[2]
  lambda <- obj.likfit$lambda
  loglik <- obj.likfit$loglik
  sill.total <- sigmasq + tausq
  n.uni <- 0
  n.bi <- 0
  lower.phi <- 0.01 * (min.dist/max.dist) 
  upper.phi <- 1000 * max.dist
  lower.sigmasq <- 0.01 * sill.total
  result <- list()
  assign(".temp.list", list(n = n,
                            z = data,
                            beta.size = dim(trend)[2],
                            kappa = obj.likfit$kappa,
                            xmat = trend,
                            ## txmat = t(trend),
                            method = obj.likfit$method,
                            dists.lowertri = dists.vec,
                            cov.model = obj.likfit$cov.model,
                            fix.lambda = obj.likfit$transform.info$fix.lambda,
                            lambda = obj.likfit$lambda,
                            lower.phi = lower.phi,
                            upper.phi = upper.phi,
                            lower.sigmasq = lower.sigmasq, 
                            phi.est = phi,
                            tausq.rel.est = tausq.rel,
                            tausq.est = tausq,
                            sigmasq.est = sigmasq), pos=1)
  if(obj.likfit$transform.info$fix.lambda == TRUE) {
    .temp.list$log.jacobian <<- obj.likfit$transform.info$log.jacobian
  }
  ##
  ## 3. One-dimentional profile likelihoods
  ##
  ##  
  ## 3.1 Profile for sigmasq
  ##  
  if(bi.only == FALSE) {
    if(any(sill.values != FALSE)) {
      n.uni <- n.uni + 1
      cat("proflik: computing profile likelihood for the sill\n")
      if(n.cov.pars == 2) {
        if(tausq == 0) {
          if(obj.likfit$transform.info$fix.lambda == FALSE) {
            ini.grid <- as.matrix(expand.grid(seq(min(range.values),
                                                  max(range.values),
                                                            l = 5),
                                                  seq(-1,1,l = 5)))
          }
          else {
            ini.grid <- as.matrix(seq(min(range.values),
                                                max(range.values),
                                                l = 10))
          }
          dimnames(ini.grid) <- list(NULL, NULL)
          .temp.list$ini.grid <<- ini.grid
          pl.sigmasq <- apply(matrix(sill.values,
                                     ncol = 1), 1, proflik.aux2, ...)
          .temp.list$ini.grid <<- NULL
        }
        else {
          stop("not yet implemented for fixed nugget != 0"
               )
        }
      }
      if(n.cov.pars == 3) {
        if(any(lambda.values != FALSE)) {
          ini.grid <- as.matrix(expand.grid(seq(min(range.values),
                                                max(range.values), l = 6),
                                            seq(0, 2 * tausq.rel, l = 4),
                                            seq(-1, 1, l = 5)))
        }
        else {
          ini.grid <- as.matrix(expand.grid(seq(min(range.values),
                                                max(range.values), l = 10),
                                            seq(0, 2 * tausq.rel, l = 4)))
        }
        dimnames(ini.grid) <- list(NULL, NULL)
        .temp.list$ini.grid <<- ini.grid
        pl.sigmasq <- apply(matrix(sill.values, ncol = 
                                   1), 1, proflik.aux9, ...)
        .temp.list$ini.grid <<- NULL
      }
      v.ord <- order(c(sigmasq, sill.values))
      result$sill <- list(sill = c(sigmasq, sill.values)[
                            v.ord], proflik.sill = c(loglik, pl.sigmasq)[
                                      v.ord], est.sill = c(sigmasq, loglik))
    }
    ##  
    ## 3.2 Profile for phi
    ##
    if(any(range.values != FALSE)) {
      n.uni <- n.uni + 1
      cat("proflik: computing profile likelihood for the range\n")
      if(n.cov.pars == 2) {
        if(tausq == 0) {
          .temp.list$nugget <<- 0
          pl.phi <- apply(matrix(range.values,
                                 ncol = 1), 1, proflik.aux0, ...)
          .temp.list$nugget <<- NULL
        }
        else {
          stop("not yet implemented for fixed nugget != 0"
               )
        }
      }
      if(n.cov.pars == 3) {
        pl.phi <- apply(matrix(range.values, ncol = 1),
                        1, proflik.aux7, ...)
      }
      v.ord <- order(c(phi, range.values))
      result$range <- list(range = c(phi, range.values)[
                             v.ord], proflik.range = c(loglik, pl.phi)[
                                       v.ord], est.range = c(phi, loglik))
    }
    ##  
    ## 3.3 Profile for \tau^2
    ##  
    if(n.cov.pars == 3) {
      if(any(nugget.values != FALSE)) {
        n.uni <- n.uni + 1
        cat("proflik: computing profile likelihood for the nugget\n"
              )
        pl.tausq <- apply(matrix(nugget.values, ncol = 
                                 1), 1, proflik.aux11, ...)
        v.ord <- order(c(tausq, nugget.values))
        result$nugget <- list(nugget = c(tausq, 
                                nugget.values)[v.ord], proflik.nugget
                              = c(loglik, pl.tausq)[v.ord], 
                              est.nugget = c(tausq, loglik))
      }
      ##  
      ## 3.4 Profile for relative \tau^2
      ##
      if(any(nugget.rel.values != FALSE)) {
        cat("proflik: computing profile likelihood for the relative nugget\n"
              )
        n.uni <- n.uni + 1
        pl.tausq.rel <- apply(matrix(nugget.rel.values,
                                     ncol = 1), 1, proflik.aux5, ...)
        v.ord <- order(c(tausq.rel, nugget.rel.values))
        result$nugget.rel <- list(nugget.rel = c(
                                    tausq.rel, nugget.rel.values)[v.ord],
                                  proflik.nugget = c(loglik, pl.tausq.rel
                                    )[v.ord], est.nugget.rel = c(tausq.rel,
                                                loglik))
      }
    }
    ##  
    ## 3.5 Profile for \lambda
    ##
    if(any(lambda.values != FALSE)) {
      .temp.temp.list <<- .temp.list
      .temp.temp.list$coords <<- coords
      n.uni <- n.uni + 1
      cat("proflik: computing profile likelihood for the transformation parameter\n"
            )
      if(n.cov.pars == 2) {
        if(tausq == 0) {
          .temp.temp.list$fixtau <<- T
          .temp.temp.list$ini <<- c(sigmasq,phi)
          pl.lambda <- apply(as.matrix(lambda.values), 1,
                             proflik.aux23, ...)
        }
        else {
          stop("not yet implemented for fixed nugget != 0"
               )
        }
      }
      if(n.cov.pars == 3) {
        .temp.temp.list$fixtau <<- FALSE
        .temp.temp.list$ini <<- phi
        pl.lambda <- apply(matrix(lambda.values,
                                  ncol = 1), 1, proflik.aux23, ...)
      }
      v.ord <- order(c(lambda, lambda.values))
      result$lambda <- list(lambda = c(lambda, 
                              lambda.values)[v.ord], proflik.lambda
                            = c(loglik, pl.lambda)[v.ord], 
                            est.lambda = c(lambda, loglik))
      remove(.temp.temp.list, inherits=TRUE, pos=1)
    }
  }
  ##
  ## 4. Two-dimentional profile likelihoods
  ##
  ##  
  ## 4.1 Profile for \sigma^2 and \phi
  ##
  if(uni.only == FALSE){
    if(any(sillrange.values != FALSE)) {
      n.bi <- n.bi + 1
      cat("proflik: computing 2-D profile likelihood for the sill and range parameters\n")
      if(n.cov.pars == 2) {
        if(tausq == 0) {
          .temp.list$nugget <<- 0
          if(.temp.list$fix.lambda == TRUE) {
            pl.sigmasqphi <- apply(cbind(0, sillrange.values, 1), 1, loglik.spatial, ...)
          }
          else {
            pl.sigmasqphi <- apply(sillrange.values,
                                   1, proflik.aux28, ...)
          }
          .temp.list$nugget <<- NULL
        }
        else {
          stop("not yet implemented for fixed nugget != 0"
               )
        }
      }
      if(n.cov.pars == 3) {
        pl.sigmasqphi <- apply(sillrange.values, 1, proflik.aux13, ...)
      }
      names(pl.sigmasqphi) <- NULL
      result$sillrange <- list(sill = as.numeric(levels(as.factor(sillrange.values[,1]))), range = 
                               as.numeric(levels(as.factor(sillrange.values[,2]))), proflik.sillrange = pl.sigmasqphi, 
                               est.sillrange = c(sigmasq, phi, loglik))
    }
    ##  
    ## 4.2 Profile for \sigma^2 and \tau^2
    ##  
    if(any(sillnugget.values != FALSE)) {
      n.bi <- n.bi + 1
      cat("proflik: computing 2-D profile likelihood for the sill and nugget\n")
      if(obj.likfit$transform.info$fix.lambda == FALSE)
        ini.grid <- as.matrix(expand.grid(seq(min(range.values),
                                              max(range.values), l = 
                                              10), seq(-1, 1, l = 5)))
      else
        ini.grid <- as.matrix(seq(min(range.values),
                                  max(range.values), l = 10))
      dimnames(ini.grid) <- list(NULL, NULL)
      .temp.list$ini.grid <<- ini.grid
      pl.sigmasqtausq <- apply(sillnugget.values, 1, proflik.aux15, ...)
      .temp.list$ini.grid <<- NULL
      names(pl.sigmasqtausq) <- NULL
      result$sillnugget <- list(sill = as.numeric(levels(as.factor(sillnugget.values[,1]))), nugget = as.numeric(levels(as.factor(sillnugget.values[,2]))), proflik.sillnugget = 
                                pl.sigmasqtausq, est.sillrange = c(sigmasq,
                                                   tausq, loglik))
    }
    ##  
    ## 4.3 Profile for \phi and \tau^2
    ##
    if(any(rangenugget.values != FALSE)) {
      n.bi <- n.bi + 1
      cat("proflik: computing 2-D profile likelihood for the range and nugget\n"
            )
      .temp.list$ini.grid <<- as.matrix(seq(sigmasq/4, 5 * 
                                          sigmasq, l = 15))
      pl.phitausq <- apply(rangenugget.values, 1, proflik.aux17, ...)
      .temp.list$ini.grid <<- NULL
      names(pl.phitausq) <- NULL
      result$rangenugget <- list(range = as.numeric(levels(as.factor(rangenugget.values[,1]))), nugget
                               = as.numeric(levels(as.factor(rangenugget.values[,1]))), proflik.rangenugget = 
                               pl.phitausq, est.rangenugget = c(phi, tausq,
                                              loglik))
    }
    ##  
    ## 4.4 Profile for \sigma^2 and \tau^2_{rel}
    ##
    if(any(sillnugget.rel.values != FALSE)) {
      n.bi <- n.bi + 1
      cat("proflik: computing 2-D profile likelihood for the sill and relative nugget parameters\n"
            )
      if(.temp.list$fix.lambda == FALSE)
        ini.grid <- as.matrix(expand.grid(seq(min(range.values), max(range.values), l = 
                                              10), seq(-1, 1, l = 5)))
      else
        ini.grid <- as.matrix(seq(min(range.values),
                                  max(range.values), l = 10))
      dimnames(ini.grid) <- list(NULL, NULL)
      .temp.list$ini.grid <<- ini.grid
      pl.sigmasqtausq.rel <- apply(sillnugget.rel.values, 1, 
                                   proflik.aux19, ...)
      .temp.list$ini.grid <<- NULL
      names(pl.sigmasqtausq.rel) <- NULL
      result$sillnugget.rel <- list(sill = as.numeric(levels(as.factor(sillnugget.rel.values[,1]))), 
                                    nugget.rel = as.numeric(levels(as.factor(sillnugget.rel.values[,2]))), 
                                    proflik.sillnugget.rel = pl.sigmasqtausq.rel,
                                    est.sillrange.rel = c(sigmasq, tausq.rel, 
                                      loglik))
    }
    ##  
    ## 4.5 Profile for \phi and \tau^2_{rel}
    ##
    if(any(rangenugget.rel.values != FALSE)) {
      n.bi <- n.bi + 1
      cat("proflik: computing 2-D profile likelihood for the range and relative nugget parameters\n"
            )
      pl.phitausq.rel <- apply(rangenugget.rel.values, 1, proflik.aux30, ...)
      names(pl.phitausq.rel) <- NULL
      result$rangenugget.rel <- list(range = as.numeric(levels(as.factor(rangenugget.rel.values[,1]))),
                                   nugget.rel = as.numeric(levels(as.factor(rangenugget.rel.values[,2]))), 
                                   proflik.rangenugget.rel = pl.phitausq.rel,
                                   "est.rangenugget .rel" = c(phi, tausq.rel,
                                     loglik))
    }
  }
  ##  
  ## 4.6 Profile for \sigma^2 and \lambda
  ##
  if(any(silllambda.values != FALSE)) {
    n.bi <- n.bi + 1
    cat("proflik: computing 2-D profile likelihood for the sill and transformation parameters\n"
          )
    if(n.cov.pars == 2) {
      ini.grid <- as.matrix(seq(min(range.values), max(
                                                       range.values), l = 10))
      dimnames(ini.grid) <- list(NULL, NULL)
      .temp.list$ini.grid <<- ini.grid
      if(tausq == 0) {
        .temp.list$nugget <<- 0
        pl.sigmasqlambda <- apply(silllambda.values, 1,
                                  proflik.aux24, ...)
        .temp.list$ini.grid <<- .temp.list$nugget <<- NULL
      }
      else {
        stop("not yet implemented for fixed nugget != 0"
             )
      }
    }
    if(n.cov.pars == 3) {
      ini.grid <- as.matrix(expand.grid(seq(min(range.values),
                                            max(range.values), l = 10), seq(0, 1, l = 5)))
      dimnames(ini.grid) <- list(NULL, NULL)
      .temp.list$ini.grid <<- ini.grid
      pl.sigmasqlambda <- apply(sigmasqlambda.values, 1, 
                                proflik.aux27, ...)
      .temp.list$ini.grid <<- NULL
    }
    names(pl.sigmasqlambda) <- NULL
    result$silllambda <- list(sill = as.numeric(levels(as.factor(silllambda.values[,1]))), lambda = as.numeric(levels(as.factor(silllambda.values[,2]))), proflik.silllambda = pl.sigmasqlambda,
                              est.silllambda = c(sigmasq, lambda, loglik))
  }
  ##  
  ## 4.7 Profile for \phi and \lambda
  ##
  if(any(rangelambda.values != FALSE)) {
    .temp.list$data <<- .temp.list$z
    n.bi <- n.bi + 1
    cat("proflik: computing 2-D profile likelihood for the range and transformation parameters\n"
              )
    if(n.cov.pars == 2) {
      if(tausq == 0) {
        .temp.list$nugget <<- 0
        pl.philambda <- apply(rangelambda.values, 1, 
                              proflik.aux1, ...)
        .temp.list$nugget <<- NULL
      }
      else {
        stop("not yet implemented for fixed nugget != 0"
             )
      }
    }
    if(n.cov.pars == 3) {
      pl.philambda <- apply(rangelambda.values, 1, proflik.aux31, ...)
    }
    names(pl.philambda) <- NULL
    result$rangelambda <- list(range = as.numeric(levels(as.factor(rangelambda.values[,1]))), lambda = as.numeric(levels(as.factor(rangelambda.values[,2]))), proflik.rangelambda = pl.philambda,
                               est.rangelambda = c(phi, lambda, loglik))
  }
  ##  
  ## 4.8 Profile for \tau^2 and \lambda
  ##                                        
  if(any(nuggetlambda.values != FALSE)) {
    n.bi <- n.bi + 1
    cat("proflik: computing 2-D profile likelihood for the nugget and transformation parameters\n"
          )
    pl.nuggetlambda <- apply(nuggetlambda.values, 1, proflik.aux32, ...)
      names(pl.nuggetlambda) <- NULL
    result$nuggetlambda <- list(nugget = as.numeric(levels(as.factor(nuggetlambda.values[,1]))), lambda = as.numeric(levels(as.factor(nuggetlambda.values[,2])))
                                , proflik.nuggetlambda = pl.nuggetlambda,
                                est.nuggetlambda = c(tausq, lambda, loglik))
  }
  ##  
  ## 4.9 2-D Profile for \tau^2_{rel} and \lambda
  ##
  if(any(nugget.rellambda.values != FALSE)) {
    n.bi <- n.bi + 1
    pl.nugget.rellambda <- apply(nugget.rellambda.values, 1, proflik.aux33, ...)
    names(pl.nugget.rellambda) <- NULL
    result$nugget.rellambda <- list(nugget.rel = as.numeric(levels(as.factor(nugget.rellambda.values[,1]))),
                                    lambda = as.numeric(levels(as.factor(nugget.rellambda.values[,2]))), proflik.nugget.rellambda = 
                                    pl.nugget.rellambda, est.nugget.rellambda = c(tausq.rel,
                                                           lambda, loglik))
  }
  result$n.uni <- n.uni
  result$n.bi <- n.bi
  result$method <- obj.likfit$method
  result$call <- call.fc
  class(result) <- "proflik"
  return(result)
}

"proflik.aux0" <-
  function(phi, ...)
{
  ## This function computes the value of the profile likelihood for the correlation parameter \phi when nugget effect is not included in the model.
  ## It requires the minimisation of the function wrt \phi for each value of \lambda, if this transformation parameter is included in the model
  ## This is an auxiliary function called by likfit.proflik
  ##
  if(.temp.list$fix.lambda == TRUE)
    proflik <- proflik.aux1(phi = phi)
  else {
    .temp.list$phi <<- phi
    proflik <-  - (optim(.temp.list$lambda, proflik.aux1.1, method="L-BFGS-B", lower
                         = -2, upper = 2, ...)$value)
    return(proflik)
  }
}
"proflik.aux1" <-
  function(philambda, ...)
{
  ## This function computes the value of the profile likelihood for the correlation function scale parameter \phi when nugget effect = 0
  if(length(philambda) == 2) lambda <- philambda[2]
  else lambda <- 1
  n <- .temp.list$n
  main <- proflik.main(tausq=.temp.list$nugget, sigmasq=1, phi=philambda[1], lambda = lambda)
  if(.temp.list$method == "ML") {
    proflik <-  - (n/2) * log(2 * pi) - main$log.det.to.half -
      (n/2) * log(main$ssresmat/n) - (n/2) + main$
    log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    proflik <-  - ((n - beta.size)/2) * log(2 * pi) - main$
    log.det.to.half - ((n - beta.size)/2) * log(main$ssresmat/
                                                n) - (n/2) + 0.5 * sum(log(eigentrem$values)) + 
                                                  main$log.jacobian
  }
  return(proflik)
}
"proflik.aux10" <-
  function(phitausq.rel.lambda, ...)
{
  if(length(phitausq.rel.lambda) == 3)
    lambda <- phitausq.rel.lambda[3]
  else lambda <- 1
  phitausq.rel.lambda <- as.vector(phitausq.rel.lambda)
  n <- .temp.list$n
  phi <- phitausq.rel.lambda[1]
  tausq <- phitausq.rel.lambda[2]
  sigmasq <- .temp.list$sigmasq
  main <- proflik.main(tausq=tausq, sigmasq=1, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) + main$log.det.to.half +
      (n/2) * log(sigmasq) + (0.5/sigmasq) * main$ssresmat -
        main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) + main$
    log.det.to.half + ((n - beta.size)/2) * log(sigmasq) +
      (0.5/sigmasq) * main$ssresmat - 0.5 * sum(log(eigentrem$
                                               values)) - main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux11" <-
  function(tausq, ...)
{
  ## This function computes the value of the profile likelihood for the parameter \tau^2.
  ## It requires the minimisation of the function wrt \sigma^2, \phi and \lambda (if the case)  for each value of \tau^2.
  ## This is an auxiliary function called by proflik.
  .temp.list$nugget <<- as.vector(tausq)
  if(.temp.list$fix.lambda == TRUE) {
    sigmasqphi.res <- optim(c(.temp.list$sigmasq.est, .temp.list$phi.est),
                            proflik.aux12,method="L-BFGS-B",
                            lower = c(.temp.list$lower.sigmasq,
                              .temp.list$lower.phi),
                            upper=c(+Inf, .temp.list$upper.phi), ...)$value
  }
  else {
    sigmasqphi.res <- optim(c(.temp.list$sigmasq.est, .temp.list$
                              phi.est, .temp.list$lambda), proflik.aux12,method="L-BFGS-B",  lower = c(.temp.list$lower.sigmasq, .temp.list$lower.phi, -2),
                            upper = c( + Inf, .temp.list$upper.phi, 2), ...)$value
  }
  .temp.list$nugget <<- NULL
  return( - sigmasqphi.res)    
}

"proflik.aux1.1" <-
  function(lambda, ...)
{
  ## This function computes the value of the profile likelihood for the correlation function scale parameter \phi when nugget effect = 0
  phi <- .temp.list$phi
  n <- .temp.list$n
  main <- proflik.main(tausq=.temp.list$nugget, sigmasq=1, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) + main$log.det.to.half +
      (n/2) * log(main$ssresmat/n) + (n/2) - main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) + main$
    log.det.to.half + ((n - beta.size)/2) * log(main$ssresmat/n) +
      (n/2) - 0.5 * sum(log(eigentrem$values)) - 
        main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}

"proflik.aux12" <-
  function(sigmasqphi.lambda, ...)
{
  ## This function computes the value of the profile likelihood for the nugget parameter \tau^2, minimizing the likelihood wrt correlation function scale parameter \phi (range), the random field scale parameter \sigma^2 (sill) and the transformation parameter \lambda. 
  if(length(sigmasqphi.lambda) == 3) lambda <-  sigmasqphi.lambda[3]
  else lambda <- 1
  sigmasqphi.lambda <- as.vector(sigmasqphi.lambda)
  n <- .temp.list$n
  sigmasq <- sigmasqphi.lambda[1]
  phi <- sigmasqphi.lambda[2]
  main <- proflik.main(tausq=.temp.list$nugget, sigmasq=sigmasq, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) +
      main$log.det.to.half +
        0.5 * (main$ssresmat) -
          main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) +
      main$log.det.to.half +
        0.5 * (main$ssresmat) -
          0.5 * sum(log(eigentrem$values)) -
            main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux13" <-
  function(sigmasqphi, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters \sigma^2 and \phi when the nugget is included.
  ## It requires the minimisation of the function wrt \tau^2 and \lambda (if the case) for each value of (\sigma^2, \phi)
  ## This is an auxiliary function called by likfit.proflik
  .temp.list$sigmasqphi <<- as.vector(sigmasqphi)
  if(.temp.list$fix.lambda == TRUE) {
      tausq.res <- optim(.temp.list$tausq.est, proflik.aux14, method="L-BFGS-B", lower
			 = 0, ...)$value
  }
  else {
    tausq.res <- optim(
                       c(.temp.list$tausq.est, .temp.list$lambda), proflik.aux14, method="L-BFGS-B",lower = c(0, -2
                                                                                                      ), upper = c( +Inf, 2), ...)$value
  }
  .temp.list$sigmasqphi <<- NULL
  return( - tausq.res)
}

"proflik.aux14" <-
  function(tausq.lambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters (\sigma^2, \phi), minimizing the likelihood wrt the nugget parameter \tau^2.
  ## This functions is called by the auxiliary function proflik.aux13
  if(length(tausq.lambda) == 2) lambda <- tausq.lambda[2]
  else lambda <- 1
  n <- .temp.list$n
  tausq <- tausq.lambda[1]
  main <- proflik.main(tausq=tausq, .temp.list$sigmasqphi[1], phi=.temp.list$sigmasqphi[2], lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) + main$log.det.to.half + 0.5 *
      main$ssresmat - main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) + main$
    log.det.to.half + 0.5 * main$ssresmat - 0.5 * sum(log(
                                                     eigentrem$values)) - main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux15" <-
  function(sigmasqtausq, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters \sigma^2 and \tau^2
  ## It requires the minimisation of the function wrt \phi and also \lambda (if the case) for each value of (\sigma^2, \tau^2) 
  ## This is an auxiliary function called by likfit.proflik
  .temp.list$sigmasqtausq <<- as.vector(sigmasqtausq)
  if(.temp.list$fix.lambda == TRUE) {
    ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                        proflik.aux16))
    ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),
                                         ])
    phi.res <- optim(ini, proflik.aux16, method="L-BFGS-B", lower = 
                     .temp.list$lower.phi, upper=.temp.list$upper.phi, ...)$value
  }
  else {
    ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                        proflik.aux16))
    ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),
                                         ])
    phi.res <- optim(ini, proflik.aux16, method="L-BFGS-B", 
                     lower = c(.temp.list$lower.phi, -2),
                     upper = c(.temp.list$upper.phi, 2), ...)$value
  }
  .temp.list$sigmasqtausq <<- NULL
  return( - phi.res)
}

"proflik.aux16" <-
  function(phi.lambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the sill and nugget parameters (\sigma^2,\tau^2), minimising the profile likelihood wrt correlation function scale parameter \phi (and the transformation parameter \lambda
  ## This is an auxiliary function called by likfit.aux15  
  if(length(phi.lambda) == 2) lambda <- phi.lambda[2]
  else lambda <- 1
  n <- .temp.list$n
  phi <- phi.lambda[1]
  main <- proflik.main(tausq=.temp.list$sigmasqtausq[2], sigmasq=.temp.list$sigmasqtausq[1], phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) + main$log.det.to.half + 0.5 *
      main$ssresmat - main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) + main$
    log.det.to.half + 0.5 * main$ssresmat - 0.5 * sum(log(
                                                     eigentrem$values)) -
                                                       main$log.jacobian
  }
    return(as.vector(round(neglik, dig=8)))
}
"proflik.aux17" <-
  function(phitausq, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters (\phi, \tau^2)
  ## It requires the minimisation of the function wrt \sigma^2 and \lambda (if the case) for each value of (\phi, \tau^2) 
  ## This is an auxiliary function called by likfit.proflik
  .temp.list$phitausq <<- as.vector(phitausq)
  if(.temp.list$fix.lambda == TRUE) {
    ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                        proflik.aux18))
    ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),])
    sigmasq.res <- optim(ini, proflik.aux18, method="L-BFGS-B", 
                         lower = .temp.list$lower.sigmasq, ...)$value
  }
  else {
    sigmasq.res <- optim(c(.temp.list$sigmasq.est, .temp.list$lambda
                           ), proflik.aux18, method="L-BFGS-B", lower = c(.temp.list$lower.sigmasq,
                                                                  -2), upper = c( + Inf, 2), ...)$value
  }
  .temp.list$phitausq <<- NULL
  return( - sigmasq.res)
}

"proflik.aux18" <-
  function(sigmasq.lambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the range and nugget parameters (\phi, \tau^2), minimising the likelihood wrt the random field scale parameter \sigma^2 (sill) ant the transformation parameter \lambda. 
  ## This is an auxiliary function called by likfit.aux17.
  if(length(sigmasq.lambda) == 2) lambda <- sigmasq.lambda[2]
  else lambda <- 1
  n <- .temp.list$n
  sigmasq <- sigmasq.lambda[1]
  main <- proflik.main(tausq=.temp.list$phitausq[2], sigmasq=sigmasq, phi=.temp.list$phitausq[1], lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) + main$log.det.to.half + 0.5 *
      main$ssresmat - main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) + main$
    log.det.to.half + 0.5 * main$ssresmat - 0.5 * sum(log(
                                                     eigentrem$values)) -
                                                       main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux19" <-
  function(sigmasqtausq.rel, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters (\sigma^2, \tau^2_{rel})
  ## It requires the minimisation of the function wrt \phi and \lambda (if the case) for each value of (\sigma^2, \tau^2_{rel})
  ## This is an auxiliary function called by likfit.proflik
  .temp.list$sigmasqtausq.rel <<- as.vector(sigmasqtausq.rel)
  if(.temp.list$fix.lambda == TRUE) {
    phi.res <- optim(.temp.list$phi.est, proflik.aux20, method="L-BFGS-B", lower = 
                     .temp.list$lower.phi, upper=.temp.list$upper.phi, ...)$value
  }
  else {
    phi.res <- optim(c(.temp.list$phi.est, .temp.list$lambda, ...), proflik.aux20, method="L-BFGS-B", 
                     lower = c(.temp.list$lower.phi, -2),
                     upper = c(.temp.list$upper.phi, 2), ...)$value
  }
  .temp.list$sigmasqtausq.rel <<- NULL
  return( - phi.res)
}


"proflik.aux2" <-
  function(sigmasq, ...)
{
  ## This function computes the value of the profile likelihood for the random field scale (variance) parameter \sigma^2 when nugget effect is not included in the model.
  ## It requires the minimisation of the function wrt \phi and maybe \lambda for each value of \sigma^2
  ## This is an auxiliary function called by likfit.proflik
  ##
  .temp.list$sigmasq <<- as.vector(sigmasq)
  if(.temp.list$fix.lambda == TRUE) {
    ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                        proflik.aux3))
    ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),
                                         ])
    phi.res <- optim(ini , proflik.aux3, method="L-BFGS-B",
                     lower = .temp.list$lower.phi,
                     upper=.temp.list$upper.phi, ...)$value
  }
  else {
    ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                        proflik.aux3))
    ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),])
    phi.res <- optim(ini, proflik.aux3, method="L-BFGS-B",
                     lower = c(.temp.list$lower.phi, -2),
                     upper = c(.temp.list$upper.phi, 2), ...)$value
  }
  .temp.list$sigmasq <<- NULL
  return( - phi.res)
}

"proflik.aux20" <-
  function(phi.lambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the sill and relative nugget parameters (\sigma^2, \tau^2_{rel}), minimising the likelihood wrt the correlation function scale parameter \phi and the transformation parameter \lambda.
  ## This is an auxiliary function called by likfit.aux19.
  phi.lambda <- as.vector(phi.lambda)
  if(length(phi.lambda) == 2) lambda <- phi.lambda[2]
  else lambda <- 1
  sigmasqtausq.rel <- as.vector(.temp.list$sigmasqtausq.rel)
  sigmasq <- sigmasqtausq.rel[1]
  tausq.rel <- sigmasqtausq.rel[2]
  phi <- phi.lambda[1]
  n <- .temp.list$n
  main <- proflik.main(tausq=tausq.rel, sigmasq=1, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) +
      main$log.det.to.half +
        (n/2) * log(sigmasq) +
          (0.5/sigmasq) * main$ssresmat -
            main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) +
      main$log.det.to.half +
        (n/2) * log(sigmasq) +
          (0.5/sigmasq) * main$ssresmat -
            0.5 * sum(log(eigentrem$values)) -
              main$log.jacobian
  } 
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux21" <-
function(phitausq.rel, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters (\phi, \tau^2_{rel})
  ## This is an auxiliary function called by likfit.proflik
  phitausq.rel <- as.vector(phitausq.rel)
  phi <- phitausq.rel[1]
  tausq.rel <- phitausq.rel[2]
  n <- .temp.list$n
  main <- proflik.main(tausq=tausq.rel, sigmasq=1, phi=phi, lambda = 1)
  sigmasq.hat <- main$ssresmat/n
  if(.temp.list$method == "ML") {
    proflik <-  - (n/2) * log(2 * pi) -
      main$log.det.to.half -
      (n/2) * log(sigmasq.hat) -
        (n/2) -
          main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    proflik <-  - ((n - beta.size)/2) * log(2 * pi) -
      main$log.det.to.half -
        (n/2) * log(sigmasq.hat) -
          (n/2) +
            0.5 * sum(log(eigentrem$values)) -
              main$log.jacobian
  }
  return(proflik)
}

"proflik.aux21.1" <-
  function(lambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters (\phi, \tau^2_{rel})
  ## This requires minimasation wrt to the transformation parameter \lambda
  ## This is an auxiliary function called by likfit.proflik
  n <- .temp.list$n
  main <- proflik.main(tausq = .temp.list$phitausq.rel[2], sigmasq = 1,
                       phi = .temp.list$phitausq.rel[1], lambda = lambda)
  sigmasq.hat <- main$ssresmat/n
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) +
      main$log.det.to.half + (n/2) * log(sigmasq.hat) +
        (n/2) -
          main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) +
      main$log.det.to.half +
        (n/2) * log(sigmasq.hat) +
          (n/2) -
            0.5 * sum(log(eigentrem$values)) -
              main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}

"proflik.aux22" <-
  function(sigmasq, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the range and nugget parameters (\phi, \tau^2), minimising the likelihood wrt the random field scale parameter \sigma^2 (sill) 
  ## This is an auxiliary function called by likfit.aux17
  n <- .temp.list$n
  main <- proflik.main(tausq=.temp.list$phitausq[2], sigmasq=sigmasq, phi= .temp.list$phitausq[1], lambda = 1)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) +
      main$log.det.to.half +
        0.5 * main$ssresmat -
          main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) +
      main$log.det.to.half +
        0.5 * main$ssresmat -
          0.5 * sum(log(eigentrem$values)) -
            main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}

"proflik.aux23" <-
  function(lambda, ...)
{
  ## This function computes the value of the profile likelihood for the transformation parameter \lambda
  ## It requires the minimisation of the function wrt \phi and \tau^2 and sigma^2 for each value of \lambda
  ## This is an auxiliary function called by proflik
  lambda <- as.vector(lambda)
  if(.temp.temp.list$fixtau == FALSE) {
    if(lambda == 0)
      data.l <- log(.temp.list$z)
    else data.l <- ((.temp.list$z^lambda) - 1)/lambda
    var.l <- var(data.l)
    ini.l <- c(0.10000000000000001 * var.l, var.l, .temp.temp.list$ini)
  }
  else
    ini.l <- .temp.temp.list$ini
  if(dim(.temp.list$xmat)[2] == 1 & all(.temp.list$xmat == 1))
    trend.mat <- "cte"
  else
    trend.mat <- ~ (.temp.list$xmat[,-1])
  lambda.res <- likfit(coords = .temp.temp.list$coords, data = .temp.list$z,
                       ini = ini.l, trend = trend.mat, fix.nugget = 
                       .temp.temp.list$fixtau,
                       method = .temp.list$method, cov.model = 
                       .temp.list$cov.model, kappa = .temp.list$kappa, fix.lambda = TRUE,
                       lambda = lambda, messages.screen = FALSE)$loglik
  .temp.list <<- .temp.temp.list
  return(lambda.res)
}

"proflik.aux24" <-
  function(sigmasqlambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the parameters (\sigma^2, \lambda) when there is no nugget effect (\tau^2 = 0, fixed)
  ## It requires the minimisation of the function wrt \phi for each value of (\sigma^2, \lambda)
  ## This is an auxiliary function called by proflik
  sigmasqlambda <- as.vector(sigmasqlambda)
  .temp.list$sigmasq <<- sigmasqlambda[1]
  lambda <- sigmasqlambda[2]
  if(lambda == 1) {
    .temp.list$log.jacobian <<- 0
  }
  else {
    if(any(.temp.list$z <= 0))
      stop("Transformation option not allowed when there are zeros or negative data"
           )
    .temp.list$log.jacobian <<- sum(log(.temp.list$z^(lambda - 1)))
    if(lambda == 0)
      .temp.list$z <<- log(.temp.list$z)
    else .temp.list$z <<- ((.temp.list$z^lambda) - 1)/lambda
  }
  ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                      proflik.aux3))
  ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),
                                       ])
  phi.res <- optim(ini, proflik.aux3, method="L-BFGS-B", lower = .temp.list$
                   lower.phi, upper = .temp.list$upper.phi, ...)$value
  .temp.list$log.jacobian <<- NULL
  .temp.list$sigmasq <<- NULL
  .temp.list$z <<- .temp.list$data
  return( - phi.res)
}

"proflik.aux27" <-
  function(sigmasqlambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for sill \sigma^2 and the transformation parameter \lambda
  ## It requires the minimisation of the function wrt \phi and \tau^2 and for each value of (\sigma^2,\lambda)
  ## This is an auxiliary function called by proflik.
  sigmasqlambda <- as.vector(sigmasqlambda)
  .temp.list$sigmasq <<- sigmasqlambda[1]
  lambda <- sigmasqlambda[2]
  if(lambda == 1) {
    .temp.list$log.jacobian <<- 0
  }
  else {
    .temp.list$fix.lambda <<- T
    if(any(.temp.list$z^(lambda - 1) <= 0))
      .temp.list$log.jacobian <<- log(prod(.temp.list$z^(lambda -
                                                         1)))
    else .temp.list$log.jacobian <<- sum(log(.temp.list$z^(lambda -
                                                           1)))
    if(lambda == 0)
      .temp.list$z <<- log(.temp.list$z)
    else .temp.list$z <<- ((.temp.list$z^lambda) - 1)/lambda
  }
  ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                      proflik.aux10))
  ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),
                                       ])        
  phitausq.rel.res <- optim(ini, proflik.aux10, method="L-BFGS-B",
                            lower = c(.temp.list$lower.phi,
                              0), upper=c(.temp.list$upper.phi, 100), ...)$value
  .temp.list$log.jacobian <<- NULL
  .temp.list$sigmasq <<- NULL
  .temp.list$z <<- .temp.list$data
  return( - phitausq.rel.res)
}

"proflik.aux28" <-
  function(sigmasqphi, ...)
{
  ## This function computes the value of the 2-D profile likelihood for the random field scale (variance) parameter \sigma^2  and the correlation function parameter \phi when nugget effect is not included in the model.
  ## It requires the minimisation of the function wrt \lambda for each value of (\sigma^2, \phi)
  ## This is an auxiliary function called by likfit.proflik
  ##
  ini.seq <- seq(-1.5, 1.5, l=7)
  .temp.list$sigmasqphi <<- as.vector(sigmasqphi)
  lambda.lik <- apply(as.matrix(ini.seq), 1, proflik.aux4)
  ini <- ini.seq[lambda.lik == max(lambda.lik)]
    lambda.res <- optim(ini, proflik.aux4, method="L-BFGS-B", lower = -2.5, upper = 2.5, ...)$value
  .temp.list$sigmasqphi <<- NULL
  return( - lambda.res)
}

"proflik.aux30" <-
  function(phitausq.rel, ...)
{
  ## This function computes the value of the profile likelihood for the correlation parameter \phi when nugget effect is not included in the model.
  ## It requires the minimisation of the function wrt \phi for each value of \lambda, if this transformation parameter is included in the model
  ## This is an auxiliary function called by likfit.proflik
  ##
  if(.temp.list$fix.lambda == TRUE)
    proflik <- proflik.aux21(phitausq.rel = phitausq.rel)
  else {
    .temp.list$phitausq.rel <<- phitausq.rel
    proflik <-  - (optim(.temp.list$lambda, proflik.aux21.1, method="L-BFGS-B", lower =
                         -2, upper = 2, ...)$value)
    .temp.list$phitausq.rel <<- NULL
  }
  return(proflik)
}


"proflik.aux3" <-
  function(phi.lambda, ...)
{
  ## This function computer the negative of the likelihood function for the correlation function scale parameter \phi (and maybe the transformation parameter \lambda) only for models with fixed nugget effect (i.e., when it is not a parameter to be estimated) 
  ## This function is used when computing the profile likelihood for \sigma^2
  ## This is an auxiliary function called by proflik.aux2
  ##  phi <- pmax(phi, .temp.list$lower.phi)
  if(length(phi.lambda) == 2)
    lambda <- phi.lambda[2]
  else lambda <- 1
  sigmasq <- .temp.list$sigmasq
  phi <- phi.lambda[1]
  n <- .temp.list$n
  main <- proflik.main(tausq=0, sigmasq=1, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) +
      main$log.det.to.half +
      (n/2) * log(sigmasq) + (0.5/sigmasq) * main$ssresmat - 
        main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) +
      main$log.det.to.half +
        ((n - beta.size)/2) * log(sigmasq) +
          (0.5/sigmasq) * main$ssresmat -
            0.5 * sum(log(eigentrem$values)) -
              main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}

"proflik.aux31" <-
  function(philambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for range \phi and the transformation parameter \lambda.
  ## It requires the minimisation of the function wrt \tau^2_{rel} and for each value of (\phi,\lambda).
  ## This is an auxiliary function called by proflik.
  philambda <- as.vector(philambda)
  .temp.list$phi <<- philambda[1]
  .temp.list$lambda <- philambda[2]
  tausq.rel.res <- optim(.temp.list$tausq.rel.est, proflik.aux8, method="L-BFGS-B", lower = 
                         0, upper=100, ...)$value
  .temp.list$phi <<- NULL
  return( - tausq.rel.res)
}

"proflik.aux32" <-
  function(tausqlambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for nugget \tau^2 and the transformation parameter \lambda.
                                        # It requires the minimisation of the function wrt \phi and \sigma^2 and for each value of (\tau^2,\lambda).
                                        # This is an auxiliary function called by proflik.
  tausqlambda <- as.vector(tausqlambda)
  .temp.list$nugget <<- tausqlambda[1]
  lambda <- tausqlambda[2]
  if(lambda == 1) {
    .temp.list$log.jacobian <<- 0
  }
  else {
    if(any(.temp.list$z^(lambda - 1) <= 0))
      .temp.list$log.jacobian <<- log(prod(.temp.list$z^(lambda -
                                                         1)))
    else .temp.list$log.jacobian <<- sum(log(.temp.list$z^(lambda -
                                                           1)))
    if(lambda == 0)
      .temp.list$z <<- log(.temp.list$z)
    else .temp.list$z <<- ((.temp.list$z^lambda) - 1)/lambda
  }
  sigmasqphi.res <- optim(c(.temp.list$sigmasq.est, .temp.list$phi.est), proflik.aux12, method="L-BFGS-B",
                          lower = c(.temp.list$lower.sigmasq, .temp.list$
                            lower.phi), upper=c(+Inf, .temp.list$upper.phi), ...)$value
  .temp.list$log.jacobian <<- NULL
  .temp.list$z <<- .temp.list$data
  .temp.list$nugget <<- NULL
  return( - sigmasqphi.res)
}

"proflik.aux33" <-
  function(tausq.rellambda, ...)
{
  ## This function computes the value of the 2-D profile likelihood for nugget \tau^2 and the transformation parameter \lambda.
  ## It requires the minimisation of the function wrt \phi for each value of (\tau^2,\lambda).
  ## This is an auxiliary function called by proflik.
  tausq.rellambda <- as.vector(tausq.rellambda)
  .temp.list$nugget.rel <<- tausq.rellambda[1]
  lambda <- tausq.rellambda[2]
  if(lambda == 1) {
    .temp.list$log.jacobian <<- 0
  }
  else {
    if(any(.temp.list$z^(lambda - 1) <= 0))
      .temp.list$log.jacobian <<- log(prod(.temp.list$z^(lambda -
                                                         1)))
    else .temp.list$log.jacobian <<- sum(log(.temp.list$z^(lambda -
                                                           1)))
    if(lambda == 0)
      .temp.list$z <<- log(.temp.list$z)
    else .temp.list$z <<- ((.temp.list$z^lambda) - 1)/lambda
  }
  phi.res <- optim(.temp.list$phi.est, proflik.aux6, method="L-BFGS-B", lower = .temp.list$
                    lower.phi, upper=.temp.list$upper.phi, ...)$value
  .temp.list$log.jacobian <<- NULL
  .temp.list$nugget.rel <<- NULL
  .temp.list$z <<- .temp.list$data
  return( - phi.res)
}
"proflik.aux4" <-
  function(lambda, ...)
{
  ## This function computer the values of the profile likelihood function for the parameters \phi  and \sigma^2 for models with nugget effect = 0, including the tranformation parameter \lambda
  ## This is an auxiliary function called by proflik.aux28
  ##
  sigmasqphi <- as.vector(.temp.list$sigmasqphi)
  sigmasq <- sigmasqphi[1]
  phi <- sigmasqphi[2]
  n <- .temp.list$n
  if(lambda > 0.999 & lambda < 1.001)
    lambda <- 1
  main <- proflik.main(tausq=.temp.list$nugget, sigmasq = sigmasq, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- ((n/2) * log(2 * pi) +
               main$log.det.to.half +
               0.5 * main$ssresmat - 
               main$log.jacobian)
  }
  if(.temp.list$method == "RML") {
    xx.eigen <- eigen(crossprod(.temp.list$xmat), symmetric = TRUE,
                      only.values = TRUE)
    neglik <- (((n - beta.size)/2) * log(2 * pi) -
               0.5 * sum(log(xx.eigen$values)) +
               main$log.det.to.half +
               (0.5) * main$ssresmat +
               choldet +
               main$log.jacobian)
  }
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux5" <-
  function(tausq.rel, ...)
{
  ## This function computes the value of the profile likelihood for the parameter \tau^2_{rel}.
  ## It requires the minimisation of the function wrt \phi and \lambda (if the case) for each value of \tau^2_{rel}.
  ## This is an auxiliary function called by proflik.
  .temp.list$nugget.rel <<- as.vector(tausq.rel)
  if(.temp.list$fix.lambda == TRUE) {
    phi.res <- optim(.temp.list$phi.est, proflik.aux6, method="L-BFGS-B", lower = 
                     .temp.list$lower.phi, upper=.temp.list$upper.phi, ...)$value
  }
  else {
    if(.temp.list$minimisation.function == "optim") 
      phi.res <- optim(c(.temp.list$phi.est, .temp.list$lambda), proflik.aux6, method="L-BFGS-B", 
                       lower = c(.temp.list$lower.phi, -2),
                       upper = c(.temp.list$upper.phi, 2), ...)$value
    else
      phi.res <- nlmP(proflik.aux6, c(.temp.list$phi.est, .temp.list$lambda), 
                      lower = c(.temp.list$lower.phi, -2),
                      upper = c(.temp.list$upper.phi, 2), ...)$minimum
  }
  .temp.list$nugget.rel <<- NULL
  return( - phi.res)
}

"proflik.aux6" <-
function(phi.lambda, ...)
{
  ## This function computes the value of the profile likelihood for the relative nugget parameter \tau^2_{rel}, minimizing the likelihood wrt correlation function scale parameter \phi (range) and the transformation parameter \lambda.
  if(length(phi.lambda) == 2) lambda <- phi.lambda[2] else lambda <- 1
  phi.lambda <- as.vector(phi.lambda)
  phi <- phi.lambda[1]
  n <- .temp.list$n
  main <- proflik.main(tausq=.temp.list$nugget.rel, sigmasq=1, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) +
      main$log.det.to.half +
        (n/2) * log(main$ssresmat/n) +
          (n/2) -
            main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- ((n - beta.size)/2) * log(2 * pi) +
      main$log.det.to.half +
        ((n - beta.size)/2) * log(main$ssresmat/n) +
          (n/2) -
            0.5 * sum(log(eigentrem$values)) -
              main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux7" <-
  function(phi, ...)
{
  ## This function computes the value of the profile likelihood for the parameter \phi when the nugget \tau^2 is included in the model
  ## It requires the minimisation of the function wrt relative \tau^2_{rel} for each value of \phi
  ## This is an auxiliary function called by proflik.
  .temp.list$phi <<- as.vector(phi)
  if(.temp.list$fix.lambda == TRUE) {
    .temp.list$lambda <<- 1
    tausq.rel.res <- optim(.temp.list$tausq.rel.est, proflik.aux8, method="L-BFGS-B", 
                           lower = 0, upper=100, ...)$value
    .temp.list$lambda <<- NULL
  }
  else {
    tausq.rel.res <- optim(c(.temp.list$tausq.rel.est, .temp.list$lambda), proflik.aux8, method="L-BFGS-B", lower = c(0, -2), upper = c(100, 2), ...)$value
  }
  .temp.list$phi <<- NULL
  return( - tausq.rel.res)
}
"proflik.aux8" <-
  function(tausq.rel.lambda, ...)
{
  ## This function computes the value of the profile likelihood for the correlation function scale parameter \phi (and lambda), minimizing the likelihood wrt relative nugget parameter \tau^2_{rel}
  if(length(tausq.rel.lambda) == 2)
    lambda <- tausq.rel.lambda[2]
  else lambda <- .temp.list$lambda
  n <- .temp.list$n
  phi <- .temp.list$phi
  tausq.rel <- tausq.rel.lambda[1]
  main <- proflik.main(tausq=tausq.rel, sigmasq=1, phi=phi, lambda = lambda)
  if(.temp.list$method == "ML") {
    neglik <- (n/2) * log(2 * pi) + main$log.det.to.half + (
                                                              n/2) * log(main$ssresmat/n) + (n/2) - main$log.jacobian
  }
  if(.temp.list$method == "RML") {
    eigentrem <- eigen(main$ixix, symmetric = TRUE, only.values = TRUE)
    neglik <- (((n - beta.size)/2) * log(2 * pi) + main$
               log.det.to.half + ((n - beta.size)/2) * log(main$ssresmat/
                                                           n) + (n/2) - 0.5 * sum(log(eigentrem$values))) - 
                                                             main$log.jacobian
  }
  return(as.vector(round(neglik, dig=8)))
}
"proflik.aux9" <-
  function(sigmasq, ...)
{
  ## This function computes the value of the profile likelihood for the parameter \sigma^2 when \tau^2 is included in the model
  ## It requires the minimisation of the function wrt \phi and \tau^2 for each value of \sigma^2
  ## This is an auxiliary function called by likfit.proflik
  .temp.list$sigmasq <<- as.vector(sigmasq)
  if(.temp.list$fix.lambda == TRUE) {
    ini.lik <- round(100000000. * apply(.temp.list$ini.grid, 1,
                                        proflik.aux10))
    ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),
                                         ])
    phitausq.rel.res <- optim(ini, proflik.aux10, method="L-BFGS-B",
                              lower = c(.temp.list$
                                lower.phi, 0),
                              upper=c(.temp.list$upper.phi, 100), ...)$value
  }
  else {
    ini.lik <- apply(.temp.list$ini.grid, 1, proflik.aux10)
    ini <- as.vector(.temp.list$ini.grid[ini.lik == min(ini.lik),])
    if(ini[2] == 0) ini[2] <- 0.01
    if(.temp.list$minimisation.function == "optim") 
      phitausq.rel.res <- optim(ini, proflik.aux10, method="L-BFGS-B", 
                                lower = c(.temp.list$lower.phi,
                                  0,-2),
                                upper = c(.temp.list$upper.phi,
                                  100, 2), ...)$value
    else
      phitausq.rel.res <- nlmP(proflik.aux10,ini, 
                               lower = c(.temp.list$lower.phi,
                                 0,-2),
                               upper = c(.temp.list$upper.phi,
                                 100, 2), ...)$minimum
  }
  .temp.list$sigmasq <<- NULL
  return( - phitausq.rel.res)
}

"plot.proflik" <-
  function(obj.proflik, pages = c("user", "one", "two"),
           uni.only = FALSE, bi.only = FALSE,
           type.bi = c("contour", "persp"),
           conf.int = c(0.90000000000000002,0.94999999999999996),
           yaxis.lims = c("conf.int", "as.computed"),
           by.col = TRUE, log.scale = FALSE, use.splines = TRUE,
           par.mar.persp = c(0, 0, 0, 0), ask = FALSE, 
           ...)
{
  ##
  ## Saving original par() parameters
  ##
#  if (is.R()) 
#    par.ori <- par(no.readonly = TRUE)
#  else par.ori <- par()
#  on.exit(par(par.ori))
  ##
  parask <- par()$ask
  par(ask = ask)
  on.exit(par(ask = parask))  
  ##
  pages <- match.arg(pages)
  if(all(is.character(yaxis.lims)))
    yaxis.lims <- match.arg(yaxis.lims)
  type.bi <- match.arg(type.bi)
  n.uni <- obj.proflik$n.uni
  n.bi <- obj.proflik$n.bi
  if(n.bi == 0)
    uni.only <- T
  if((uni.only == FALSE) & (bi.only == FALSE))
    np <- n.uni + n.bi
  if((uni.only == TRUE) & (bi.only == FALSE))
    np <- n.uni
  if((uni.only == FALSE) & (bi.only == TRUE))
    np <- n.bi
  if(n.uni==0 & np > 0) bi.only <- T
  if(n.bi==0 & np > 0) uni.only <- T
  if(pages == "one") {
    if(np >= 1 & np < 4)
      par(mfrow = c(np, 1))
    if(np >= 4) {
      if(by.col == TRUE)
        par(mfcol = c(ceiling(np/2), 2))
      else par(mfrow = c(ceiling(np/2), 2))
    }
  }
  if(pages == "two") {
    if(n.uni > 1 & n.uni < 4)
      par(mfrow = c(n.uni, 1))
    if(n.uni >= 4)
      par(mfrow = c(ceiling(n.uni/2), 2))
  }     
  if(bi.only == FALSE) {
    for(i in 1:n.uni) {
      if(obj.proflik$method == "ML")
        ylabm <- "profile log-likelihood"
      else ylabm <- "profile log-(restricted) likelihood"
      if(all(conf.int) != FALSE) {
        if(!is.numeric(conf.int) | any(conf.int > 1))
          stop("argument conf.int must be numerical (scalar or vector) with values between 0 and 1")
        conf.int.drop <- obj.proflik[[i]][[3]][2] - 0.5 * qchisq(conf.int,1)
      }
      if(all(is.character(yaxis.lims))){
        if(yaxis.lims == "conf.int")
          lik.lims <- c(min(conf.int.drop), 
                        obj.proflik[[i]][[3]][2])
        else lik.lims <- c(min(obj.proflik[[i]][[2]]),
                           obj.proflik[[i]][[3]][2])
      }
      else
        lik.lims <- yaxis.lims
      if(log.scale == TRUE) {
        if(use.splines){
          nxpoints <- 5*length(obj.proflik[[i]][[1]])
          nodups <- which(duplicated(obj.proflik[[i]][[1]]) == FALSE)
          plot(spline(x = log(obj.proflik[[i]][[1]][nodups]), 
                      y = obj.proflik[[i]][[2]][nodups],
                      n = nxpoints,
                      method="natural"), type = "l",
               xlab = paste("log-",
                 plot.proflik.aux1(names(obj.proflik[[i]])[1])),
               ylab = ylabm, ylim = lik.lims)
        }
        else{
          plot(log(obj.proflik[[i]][[1]]), 
               obj.proflik[[i]][[2]],
               type = "l",
               xlab = paste("log-",
                 plot.proflik.aux1(names(obj.proflik[[i]])[1])),
               ylab = ylabm, ylim = lik.lims)
        }
        lines(log(c(obj.proflik[[i]][[3]][1], obj.proflik[[i]][[3]][1])),
              c(min(lik.lims), obj.proflik[[i]][[3]][2]), lty = 2)
      }
      else {
        if(use.splines){
          nxpoints <- 5*length(obj.proflik[[i]][[1]])
          nodups <- which(duplicated(obj.proflik[[i]][[1]]) == FALSE)
          plot(spline(x = obj.proflik[[i]][[1]][nodups],
                      y = obj.proflik[[i]][[2]][nodups],
                      n = nxpoints,
                      method="natural"),
               type = "l",
               xlab = plot.proflik.aux1(names(obj.proflik[[i]])[1]),
               ylab = ylabm, ylim = lik.lims)
        }
        else{
          plot(obj.proflik[[i]][[1]],
               obj.proflik[[i]][[2]],
               type = "l", xlab = 
               plot.proflik.aux1(names(obj.proflik[[i]])[1]),
               ylab = ylabm, ylim = lik.lims)
        }
        lines(c(obj.proflik[[i]][[3]][1], 
                obj.proflik[[i]][[3]][1]),
              c(min(lik.lims), obj.proflik[[
                                            i]][[3]][2]), lty = 2)
      }
      abline(h = conf.int.drop, lty = 3)
    }
  }
  if(uni.only == FALSE) {
    if(pages == "two") {
      if(n.bi >= 1 & n.bi < 4)
        par(mfrow = c(n.bi, 1))
      if(n.bi >= 4)
        par(mfrow = c(ceiling(n.bi/2), 2))
    }
    for(i in 1:n.bi) {
      if(type.bi == "contour") {
        if(log.scale == TRUE) {
          contour(log(obj.proflik[[(n.uni + i)]][[1]]),
                  log(obj.proflik[[(n.uni + i)]][[2]]),
                  matrix(obj.proflik[[(n.uni + i)]][[3]],
                         ncol = length(obj.proflik[[(n.uni +i)]][[2]])),
                  xlab = paste("log-", plot.proflik.aux1(names(obj.proflik[[(n.uni + i)]][1]))),
                  ylab = paste("log-", plot.proflik.aux1(names(obj.proflik[[(n.uni + i)]][2]))),
                    ...)
          points(log(t(obj.proflik[[(n.uni + i)]][[4]][1:2])))
        }
        else {
          contour(obj.proflik[[(n.uni + i)]][[1]],
                  obj.proflik[[(n.uni + i)]][[2]],
                  matrix(obj.proflik[[(n.uni + i)]][[3]],
                         ncol = length(obj.proflik[[(n.uni + i)]][[2]])),
                  xlab = plot.proflik.aux1(names(obj.proflik[[(n.uni + i)]][1])),
                  ylab = plot.proflik.aux1(names(obj.proflik[[(n.uni + i)]][2])),
                  ...)
          points(t(obj.proflik[[(n.uni + i)]][[4]][1:2]))
        }
      }
      if(type.bi == "persp") {
        cat("For better visualisation arguments for the funtion `persp` can be passed.\nSome relevant argments are: theta, phi, r, d, among others.\n Type help(persp) for a description of the options\n")
        if(obj.proflik$method == "ML")
          zlabm <- 
            "profile log-likelihood"
        else zlabm <- "profile log-(restricted) likelihood"
        zlimm <- range(obj.proflik[[(n.uni +
                                     i)]][[3]])
        zlimm[1] <- 1.01 * zlimm[1]
        minlik <- min(obj.proflik[[(n.uni + i)]][[3]])
        if(log.scale == TRUE) {
          persp(log(obj.proflik[[(n.uni + i)]][[1]]),
                log(obj.proflik[[(n.uni + i)]][[2]]),
                matrix(obj.proflik[[(n.uni + i)]][[3]],
                       ncol = length(obj.proflik[[(n.uni + i)]][[2]])),
                xlab = plot.proflik.aux1(paste("log-", names(obj.proflik[[(n.uni + i)]][1]))),
                ylab = paste("log-", plot.proflik.aux1(names(obj.proflik[[(n.uni + i)]][2]))),
                zlab = zlabm, box = T, ...)
                                        #          pp1 <- perspp(x = log(c(obj.proflik[[(n.uni + i)]][[4]][1],
                                        #                          min( obj.proflik[[(n.uni + i)]][[1]]))[c(1, 1, 1, 2)]),
                                        #                        y = log(c(obj.proflik[[(n.uni + i)]][[4]][2],
                                        #                          min(obj.proflik[[(n.uni + i)]][[2]]))[c(1, 1, 2, 1)]),
                                        #                        z = c(minlik, obj.proflik[[(n.uni + i)]][[4]][3])[c(1, 2, 1, 1)], pp)
                                        #          segments(log(pp1$x[1]), log(pp1$y[1]), log(pp1$x[2]), log(pp1$y[2]),
                                        #                   lwd = 2)
        }
        else {
          persp(x = obj.proflik[[(n.uni + i)]][[1]],
                y = obj.proflik[[(n.uni + i)]][[2]],
                z = matrix(obj.proflik[[(n.uni + i)]][[3]],
                  ncol = length(obj.proflik[[(n.uni + i)]][[2]])),
                xlab = plot.proflik.aux1(names(obj.proflik[[(n.uni + i)]][1])),
                ylab = plot.proflik.aux1(names(obj.proflik[[(n.uni + i)]][2])),
                zlab = zlabm, box = TRUE, ...)
                                        #          pp1 <- perspp(x = c(obj.proflik[[(n.uni + i)]][[4]][1],
                                        #                          min(obj.proflik[[(n.uni + i)]][[1]]))[c(1, 1, 1, 2)],
                                        #                        y = c(obj.proflik[[(n.uni + i)]][[4]][2],
                                        #                          min(obj.proflik[[(n.uni + i)]][[2]]))[c(1, 1,2, 1)],
                                        #                        z = c(minlik, obj.proflik[[(n.uni + i)]][[4]][3])[c(1, 2, 1, 1)], pp)
                                        #          segments(pp1$x[1], pp1$y[1], pp1$x[2], pp1$y[2], lwd = 2)
        }
      }
    }
  }
  return(invisible())
}

"plot.proflik.aux1" <-
  function(parameter.name)
{
  switch(parameter.name,
         range = expression(phi),
         sill = expression(sigma^2),
         lambda = expression(lambda),
         nugget = expression(tau^2),
         nugget.rel = expression(tau^2[rel]))
}

"proflik.main" <-
  function(tausq, sigmasq, phi, lambda)
{
  z <- .temp.list$z
  n <- .temp.list$n
  if(lambda == 1) {
    log.jacobian <- .temp.list$log.jacobian
  }
  else {
    if(any(z <= 0))
      stop("Transformation option not allowed when there are zeros or negative data"
           )
    if(any(z^(lambda - 1) <= 0))
      log.jacobian <- log(prod(z^(lambda - 1)))
    else log.jacobian <- sum(log(z^(lambda - 1)))
    if(lambda == 0)
      z <- log(z)
    else z <- ((z^lambda) - 1)/lambda
  }
  beta.size <- .temp.list$beta.size
  kappa <- .temp.list$kappa
  covinf <- varcov.spatial(dists.lowertri = .temp.list$dists.lowertri,
                           cov.model = .temp.list$cov.model, kappa = kappa,
                           nugget = tausq, cov.pars = c(sigmasq, phi),
                           inv = TRUE, det = TRUE, func.inv = "eigen",
                           only.inv.lower.diag = TRUE)  
  xix <- as.double(rep(0, beta.size*beta.size))
  xix <- .C("bilinearform_XAY",
            as.double(covinf$lower.inverse),
            as.double(covinf$diag.inverse),
            as.double(as.vector(.temp.list$xmat)),
            as.double(as.vector(.temp.list$xmat)),
            as.integer(beta.size),
            as.integer(beta.size),
            as.integer(n),
            res = xix)$res
  attr(xix, "dim") <- c(beta.size, beta.size)
  if(length(as.vector(xix)) == 1) {
    ixix <- 1/xix
    choldet <- 0.5 * log(xix)
  }
  else {
    chol.xix <- chol(xix)
    ixix <- chol2inv(chol.xix)
    choldet <- sum(log(diag(chol.xix)))
  }
  xiy <- as.double(rep(0, beta.size))
  xiy <- .C("bilinearform_XAY",
            as.double(covinf$lower.inverse),
            as.double(covinf$diag.inverse),
            as.double(as.vector(.temp.list$xmat)),
            as.double(as.vector(z)),
            as.integer(beta.size),
            as.integer(1),
            as.integer(n),
            res = xiy)$res
  beta.hat <- as.vector(ixix %*% xiy)
  yiy <- as.double(0.0)
  yiy <- .C("bilinearform_XAY",
            as.double(covinf$lower.inverse),
            as.double(covinf$diag.inverse),
            as.double(as.vector(z)),
            as.double(as.vector(z)),
            as.integer(1),
            as.integer(1),
            as.integer(n),
            res = yiy)$res
  ssresmat <- as.vector(yiy - crossprod(beta.hat,xiy))
  return(list(log.det.to.half = covinf$log.det.to.half,
              ssresmat = ssresmat,
              ixix = ixix, log.jacobian = log.jacobian))
}
"olsfit" <-
  function(...)
{
  stop("this function is now obsolete.\nuse variofit() instead.")
}

"wlsfit" <-
  function(...)
{
  stop("this function is now obsolete.\nuse variofit() instead.")
}

"variofit" <-
  function (vario, ini.cov.pars, cov.model = "matern",
            fix.nugget = FALSE, nugget = 0, 
            fix.kappa = TRUE, kappa = 0.5,
            simul.number = NULL,  max.dist = "all",
            weights = c("npairs", "equal", "cressie"),
            minimisation.function,
            messages.screen = TRUE, ...) 
{
  call.fc <- match.call()
  if(class(vario) != "variogram")
    warning("object vario should preferably  be of the class \"variogram\"")
  weights <- match.arg(weights)
  if(missing(minimisation.function)){
    if(weights == "equal") minimisation.function <- "nls"
    else minimisation.function <- "optim"
  }
  if(minimisation.function == "nls" & weights != "equal"){
    warning("variofit: minimisation function nls can only be used with weights=\"equal\".\n          changed for \"optim\".\n")
    minimisation.function <- "optim"
  }
  if(messages.screen){
    cat(paste("variofit: weights used:", weights, "\n"))
    cat(paste("variofit: minimisation function used:", minimisation.function, "\n"))
  }
  cov.model <- match.arg(cov.model,
                         choices = c("matern", "exponential", "gaussian",
                           "spherical", "circular", "cubic", "wave", "power",
                           "powered.exponential", "cauchy", "gneiting",
                           "gneiting.matern", "pure.nugget"))
  if (is.matrix(vario$v) & is.null(simul.number)) 
    stop("object in vario$v is a matrix. This function works for only 1 empirical variogram at once\n")
  if (!is.null(simul.number)) 
    vario$v <- vario$v[, simul.number]
  ##
  ## Setting maximum distance
  ##
  if (max.dist == "all") 
    XY <- data.frame(u = vario$u, v = vario$v, n=vario$n)
  else
    XY <- data.frame(u = vario$u[vario$u <= max.dist],
                     v = vario$v[vario$u <= max.dist],
                     n = vario$v[vario$u <= max.dist])
  ##
  ##  Checking initial values
  ##
  if(is.matrix(ini.cov.pars) | is.data.frame(ini.cov.pars)){
    ini.cov.pars <- as.matrix(ini.cov.pars)
    if(nrow(ini.cov.pars) == 1)
      ini.cov.pars <- as.vector(ini.cov.pars)
    else{
      if((cov.model != "pure.nugget") & (ncol(ini.cov.pars) != 2))
        stop("\nini.cov.pars must be a matrix or data.frame with 2 components: \ninitial values for sigmasq (partial sill) and phi (range parameter)\n")
    }
  }
  if(is.vector(ini.cov.pars)){
    if((cov.model != "pure.nugget") & (length(ini.cov.pars) != 2))
      stop("\nini.cov.pars must be a vector with 2 components: \ninitial values for sigmasq and phi\n")
  }
  ##
  ## Preparing grid of initial values and choosing the best
  ##
  if(is.matrix(ini.cov.pars) | (length(nugget) > 1) | (length(kappa) > 1)) {
    if(messages.screen)
      cat("variofit: searching for best initial value ...")
    ini.temp <- matrix(ini.cov.pars, ncol=2)
    grid.ini <- as.matrix(expand.grid(sigmasq=unique(ini.temp[,1]), phi=unique(ini.temp[,2]), tausq=unique(nugget), kappa=unique(kappa)))
    ##  loss function:
    v.loss <- function(parms, u, v, n, cov.model, weights){
      sigmasq <- parms[1]
      phi <- parms[2]
      tausq <- parms[3]
      kappa <- parms[4]
      v.mod <- (sigmasq + tausq) -
        cov.spatial(u, cov.pars=c(sigmasq, phi), cov.model = cov.model,
                    kappa = kappa)
      if(weights == "equal")
        loss <- sum((v - v.mod)^2)
      if (weights == "npairs") 
        loss <- sum(n * (v - v.mod)^2)
      if (weights == "cressie") 
        loss <- sum((n/(v.mod^2)) * (v - v.mod)^2)
      return(loss)
    }
    grid.loss <- apply(grid.ini, 1, v.loss, u=XY$u, v=XY$v, n=XY$n, cov.model = cov.model, weights = weights)
    ini.temp <- grid.ini[which(grid.loss == min(grid.loss)),, drop=FALSE]
    if(is.R()) rownames(ini.temp) <- "initial.value"
    if(messages.screen){
      cat(" selected values:\n")
      print(rbind(round(ini.temp, dig=2), status=ifelse(c(FALSE, FALSE, fix.nugget, fix.kappa), "fix", "est")))
      cat(paste("loss value:", max(grid.loss), "\n"))
    }
    names(ini.temp) <- NULL
    ini.cov.pars <- ini.temp[1:2]
    nugget <- ini.temp[3]
    kappa <- ini.temp[4]
    grid.ini <- NULL
  }
  ##
  ## transforming kappa for constraint minimisation
  ##
  if(fix.kappa == FALSE){
    if(cov.model == "powered.exponential")
      Tkappa.ini <- log(kappa/(2-kappa))
    else
      Tkappa.ini <- log(kappa)
  }
  ##
  ## minimisation using "nls"
  ##
  if (minimisation.function == "nls") {
    require(nls)
    if(ini.cov.pars[2] == 0) ini.cov.pars <- max(XY$u)/10
    if(kappa == 0) kappa <- 0.5
    Tphi.ini <- log(ini.cov.pars[2])
    XY$cov.model <- cov.model
    ##
    if (fix.nugget) {
      XY$nugget <- nugget
      if(fix.kappa){
        XY$kappa <- kappa
        res <- nls((v-nugget) ~ matrix((1-cov.spatial(u,cov.pars=c(1,exp(Tphi)), cov.model=cov.model, kappa=kappa)), ncol=1), start=list(Tphi=Tphi.ini), data=XY, alg="plinear", ...)
      }
      else{
        if(cov.model == "powered.exponential")
          res <- nls((v-nugget) ~ matrix((1-cov.spatial(u,cov.pars=c(1,exp(Tphi)), cov.model=cov.model, kappa=(2*exp(Tkappa)/(1+exp(Tkappa))))), ncol=1), start=list(Tphi=Tphi.ini, Tkappa = Tkappa.ini), data=XY, alg="plinear", ...)
        else
          res <- nls((v-nugget) ~ matrix((1-cov.spatial(u,cov.pars=c(1,exp(Tphi)), cov.model=cov.model, kappa=exp(Tkappa))), ncol=1), start=list(Tphi=Tphi.ini, Tkappa = Tkappa.ini), data=XY, alg="plinear", ...)       
        kappa <- exp(coef(res)["Tkappa"])
        names(kappa) <- NULL
      }
      cov.pars <- coef(res)[c(".lin", "Tphi")]
      names(cov.pars) <- NULL
      cov.pars[2] <- exp(cov.pars[2])
    }
    else{
      if(fix.kappa){
        XY$kappa <- kappa
        res <- nls(v ~ cbind(1,(1- cov.spatial(u, cov.pars=c(1,exp(Tphi)), cov.model = cov.model, kappa=kappa))), start=list(Tphi=Tphi.ini), alg="plinear", data=XY, ...)
      }
      else{
        if(cov.model == "powered.exponential")
          res <- nls(v ~ cbind(1, (1-cov.spatial(u, cov.pars=c(1, exp(Tphi)), cov.model = cov.model, kappa=exp(Tkappa)))), start=list(Tphi=Tphi.ini, Tkappa = Tkappa.ini), alg="plinear", data=XY, ...)
        else
          res <- nls(v ~ cbind(1, (1-cov.spatial(u, cov.pars=c(1, exp(Tphi)), cov.model = cov.model, kappa=(2*exp(Tkappa)/(1+exp(Tkappa)))))), start=list(Tphi=Tphi.ini, Tkappa = Tkappa.ini), alg="plinear", data=XY, ...)
        kappa <- exp(coef(res)["Tkappa"]);names(kappa) <- NULL
      }
      nugget <- coef(res)[".lin1"];names(nugget) <- NULL
      cov.pars <- coef(res)[c(".lin2", "Tphi")]
      names(cov.pars) <- NULL
      cov.pars[2] <- exp(cov.pars[2]) 
    }
    if(nugget < 0 | cov.pars[1] < 0){
      warning("\nvariofit: negative variance parameter found using the default option \"nls\".\n        Try another minimisation function and/or fix some of the parameters.\n")
      temp <- c(sigmasq=cov.pars[1], phi=cov.pars[2], tausq=nugget, kappa=kappa)
      print(rbind(round(temp, dig=4), status=ifelse(c(FALSE, FALSE, fix.nugget, fix.kappa), "fix", "est")))
      return(invisible())
    }
    value <- sum(resid(res)^2)
    message <- "nls does not provides convergence message"
  }
  ##
  ## minimisation using "optim" or "nlm"
  ##
  if (minimisation.function == "nlm" | minimisation.function == "optim") {
    ##
    ## Preparing lists for the minimiser
    ##
    .global.list <- list(u = XY$u, v = XY$v, n=XY$n, fix.nugget = fix.nugget,
                         nugget = nugget, fix.kappa = fix.kappa, kappa = kappa,
                         cov.model = cov.model, m.f = minimisation.function,
                         weights = weights)
    ##
    ## Preparing initial value
    ##
    ini <- ini.cov.pars
    if(fix.nugget == FALSE) ini <- c(ini, nugget)
    if(fix.kappa == FALSE) ini <- c(ini, Tkappa.ini)
    names(ini) <- NULL
    if(minimisation.function == "nlm"){
      result <- nlm(loss.vario, ini, g.l = .global.list, ...)
      result$par <- result$estimate
      result$value <- result$minimum
      result$convergence <- result$code
      if(is.R()){
        if(!is.null(get(".temp.theta", pos =1)))
          result$par <- get(".temp.theta", pos=1)
      }
      else{
        if(!is.null(get(".temp.theta", where = 1)))
          result$par <- get(".temp.theta", where = 1)
      }
    }
    else{
      if(fix.kappa == FALSE){
        if(fix.nugget) lower <- c(0, 0, -Inf)
        else lower <- c(0, 0, 0, -Inf)
      }
      else lower <- 0
      result <- optim(ini, loss.vario, method = "L-BFGS-B",
                      lower = lower, g.l = .global.list, ...)
    }
    value <- result$value
    message <- paste(minimisation.function, "convergence code:", result$convergence)
    cov.pars <- as.vector(result$par[1:2])
    if(fix.kappa == FALSE){
      if (fix.nugget)
        Tkappa <- result$par[3]
      else{
        nugget <- result$par[3]
        Tkappa <- result$par[4]
      }
      if(.global.list$cov.model == "powered.exponential")
        kappa <- 2*(exp(Tkappa))/(1+exp(Tkappa))
      else kappa <- exp(Tkappa)
    }
    else
      if(fix.nugget == FALSE)
        nugget <- result$par[3]        
  }
  ##
  ## Estimating implicity beta
  ##
  
  ##
  ## Preparing output
  ##
  estimation <- list(nugget = nugget, cov.pars = cov.pars, 
                     cov.model = cov.model, kappa = kappa, value = value, 
                     trend = vario$trend, max.dist = max(vario$u),
                     minimisation.function = minimisation.function,
                     message = message)
  estimation$weights <- weights
  if(weights == "equal") estimation$method <- "OLS"
  else estimation$method <- "WLS"
  estimation$fix.nugget <- fix.nugget
  estimation$fix.kappa <- fix.kappa
  estimation$lambda <- vario$lambda
  estimation$call <- call.fc
  class(estimation) <- "variomodel"
  return(estimation)
}


"loss.vario" <-
  function (theta, g.l) 
{
  ##
  ## Imposing constraints for nlm
  ##
  if(g.l$m.f == "nlm"){
    .temp.theta <<- NULL
    if(g.l$fix.kappa == FALSE){
      if(g.l$fix.nugget){
        theta.minimiser <- theta[1:2]
        Tkappa <- theta[3]
      }
      else{
        theta.minimiser <- theta[1:3]
        Tkappa <- theta[4]
      }
    }
    else
      theta.minimiser <- theta
    penalty <- 10000 * sum(0 - pmin(theta.minimiser, 0))
    theta <- pmax(theta.minimiser, 0)
    if(g.l$fix.kappa == FALSE)
      theta <- c(theta.minimiser, Tkappa)
    if (any(theta.minimiser < 0))
      .temp.theta <<- theta
    else penalty <- 0
  }
  else penalty <- 0
  ##
  ## reading parameters
  ##
  if(g.l$fix.kappa == FALSE){
    if (g.l$fix.nugget){
      tausq <- g.l$nugget
      Tkappa <- theta[3]
    }
    else{
      tausq <- theta[3]
      Tkappa <- theta[4]
    }
    if(g.l$cov.model == "powered.exponential")
      kappa <- 2*(exp(Tkappa))/(1+exp(Tkappa))
    else kappa <- exp(Tkappa)
  }
  else{
    kappa <- g.l$kappa
    if (g.l$fix.nugget)
      tausq <- g.l$nugget
    else
      tausq <- theta[3]
  }
  ##
  sigmasq <- theta[1]
  phi <- theta[2]
  sill.total <- sigmasq + tausq
  ##
  ## Computing values for the theoretical variogram 
  ##
  gamma <- sill.total - cov.spatial(g.l$u, cov.model = g.l$cov.model, 
                                    kappa = kappa, cov.pars = c(sigmasq, phi))
  ##
  ## Computing loss function
  ##
  if(g.l$weight == "equal")
    loss <- sum((g.l$v - gamma)^2)
  if (g.l$weights == "npairs") 
    loss <- sum(g.l$n * (g.l$v - gamma)^2)
  if (g.l$weights == "cressie") 
    loss <- sum((g.l$n/(gamma^2)) * (g.l$v - gamma)^2)
  return(loss + penalty)
}

"print.variomodel" <-
  function(obj, digits = "default", ...)
{
  if(is.R() & digits == "default") digits <- max(3, getOption("digits") - 3)
  else digits <- options()$digits
  if(obj$fix.nugget){
    est.pars <- c(sigmasq = obj$cov.pars[1], phi=obj$cov.pars[2])
    if(obj$fix.kappa == FALSE)
      est.pars <- c(est.pars, kappa = obj$kappa)
  }
  else{
    est.pars <- c(tausq = obj$nugget, sigmasq = obj$cov.pars[1], phi=obj$cov.pars[2])    
    if(obj$fix.kappa == FALSE)
      est.pars <- c(est.pars, kappa = obj$kappa)
  }
  if(obj$weights == "equal")
    cat("variofit: model parameters estimated by OLS (ordinary least squares):\n")
  else
    cat("variofit: model parameters estimated by WLS (weighted least squares):\n")
  cat(paste("covariance model is:", obj$cov.model))
  if(obj$cov.model == "matern" | obj$cov.model == "powered.exponential" |
     obj$cov.model == "cauchy" | obj$cov.model == "gneiting.matern")
    if(obj$fix.kappa) cat(paste(" with fixed kappa =", obj$kappa)) 
  if(obj$cov.model == "matern" & obj$fix.kappa & obj$kappa == 0.5)
    cat(" (exponential)")
  cat("\n")
  if(obj$fix.nugget)
    cat(paste("fixed value for tausq = ", obj$nugget,"\n"))
  cat("parameter estimates:\n")
  print(round(est.pars, digits=digits))
  if(obj$weights == "equal")
    cat("\nvariofit: minimised sum of squares = ")
  else
      cat("\nvariofit: minimised weighted sum of squares = ")
  cat(round(obj$value, digits=digits))
  cat("\n")
  return(invisible())
}  

"summary.variomodel" <-
  function(obj)
{
  summ.lik <- list()
  if(obj$weights == "equal")
    summ.lik$pmethod <- "OLS (ordinary least squares)"
  else
    summ.lik$pmethod <- "WLS (weighted least squares)"
  summ.lik$cov.model <- obj$cov.model
  summ.lik$spatial.component <- c(sigmasq = obj$cov.pars[1], phi=obj$cov.pars[2])
  summ.lik$spatial.component.extra <- c(kappa = obj$kappa)
  summ.lik$nugget.component <- c(tausq = obj$nugget)
  summ.lik$fix.nugget <- obj$fix.nugget
  summ.lik$fix.kappa <- obj$fix.kappa
  summ.lik$sum.of.squares <- c(value = obj$value)
  if(obj$fix.nugget){
    summ.lik$estimated.pars <- c(sigmasq = obj$cov.pars[1], phi=obj$cov.pars[2])
    if(obj$fix.kappa == FALSE)
      summ.lik$estimated.pars <- c(summ.lik$estimated.pars, kappa = obj$kappa)
  }
  else{
    summ.lik$estimated.pars <- c(tausq = obj$nugget, sigmasq = obj$cov.pars[1], phi=obj$cov.pars[2])
    if(obj$fix.kappa == FALSE)
      summ.lik$estimated.pars <- c(summ.lik$estimated.pars, kappa = obj$kappa)
  }
  summ.lik$weights <- obj$weights
  summ.lik$call <- obj$call
  class(summ.lik) <- "summary.variomodel"
  return(summ.lik)
}

"print.summary.variomodel" <-
  function(obj, digits = "default", ...)
{
  if(class(obj) != "summary.variomodel")
    stop("object is not of the class \"summary.variomodel\"")
  if(is.R() & digits == "default") digits <- max(3, getOption("digits") - 3)
  else digits <- options()$digits
  cat("Summary of the parameter estimation\n")
  cat("-----------------------------------\n")
  cat(paste("Estimation method:", obj$pmethod, "\n"))
  cat("\n")
  ##
  ## Estimates of the model components
  ## Model: Y(x) = X\beta + S(x) + e 
  ##
#  cat("Parameters of the mean component (trend):")
#  cat("\n")
#  print(round(obj$mean.component, digits=digits))
#  cat("\n")
  ##
  cat("Parameters of the spatial component:")
  cat("\n")
  cat(paste("   correlation function:", obj$cov.model))
  if(obj$cov.model == "matern" & obj$fix.kappa & obj$spatial.component.extra == 0.5)
    cat(" (exponential)")
  if(obj$cov.model == "matern" | obj$cov.model == "powered.exponential" |
     obj$cov.model == "cauchy" | obj$cov.model == "gneiting.matern"){
    if(obj$fix.kappa)
      cat(paste("\n      (fixed) extra parameter kappa = ", round(obj$spatial.component.extra, digits=digits)))
    else
      cat(paste("\n      (estimated) extra parameter kappa = ", round(obj$spatial.component.extra, digits=digits)))
  }
  cat(paste("\n      (estimated) variance parameter sigmasq (partial sill) = ", round(obj$spatial.component[1], dig=digits)))
  cat(paste("\n      (estimated) cor. fct. parameter phi (range parameter)  = ", round(obj$spatial.component[2], dig=digits)))
  cat("\n")
  ##
  cat("\n")  
  cat("Parameter of the error component:")
  if(obj$fix.nugget)
    cat(paste("\n      (fixed) nugget =", round(obj$nugget.component, digits = digits)))
  else
    cat(paste("\n      (estimated) nugget = ", round(obj$nugget.component, dig=digits)))
  cat("\n")
  cat("\n")
  names(obj$sum.of.squares) <- NULL
  if(obj$weights == "equal") cat("Minimised sum of squares: ")
  else cat("Minimised weighted sum of squares: ")
  cat(round(obj$sum.of.squares, digits=digits))
  cat("\n")
  cat("\n")
  cat("Call:")
  cat("\n")
  print(obj$call)
  cat("\n")
  invisible(obj)
}

##"beta.variofit" <-
##  function(geodata, coords = geodata$coords, data=geodata$data,
##           obj.variofit)
##  {
##
##  }
"variog" <-
  function (geodata, coords = geodata$coords, data = geodata$data, 
            uvec = "default", trend = "cte", lambda = 1,
            option = c("bin", "cloud", "smooth"),
            estimator.type = c("classical", "modulus"), 
            nugget.tolerance = 0, max.dist = NULL, pairs.min = 2,
            bin.cloud = FALSE, direction = "omnidirectional", tolerance = pi/8,
            unit.angle = c("radians","degrees"),
            messages.screen = TRUE, ...) 
{
  if (is.R()){
    require(mva)
    require(modreg)
  }
  call.fc <- match.call()
  ##
  ## Directional variogram
  ##
  unit.angle <- match.arg(unit.angle)
  if(is.numeric(direction)){
    if(length(direction) > 1)
      stop("only one direction is allowed")
    if(length(tolerance) > 1)
      stop("only one tolerance value is allowed")
    if(unit.angle == "degrees"){
      ang.deg <- direction
      ang.rad <- (ang.deg * pi)/180
      tol.deg <- tolerance
      tol.rad <- (tol.deg * pi)/180
    }
    else{
      ang.rad <- direction
      ang.deg <- (ang.rad * 180)/pi
      tol.rad <- tolerance
      tol.deg <- (tol.rad * 180)/pi
    }
    if(ang.rad > pi | ang.rad < 0)
      stop("direction must be an angle in the interval [0,pi] radians")
    if(tol.rad > pi/2 | tol.rad < 0)
      stop("tolerance must be an angle in the interval [0,pi/2] radians")
    if(tol.deg >= 90){
      direction <- "omnidirectional"
      cat("variog: computing omnidirectional variogram\n")
    }
    else{
      if(messages.screen){
        cat(paste("variog: computing variogram for direction = ", round(ang.deg, dig=3), " degrees (", round(ang.rad, dig=3), " radians)\n", sep=""))
        cat(paste("        tolerance angle = ", round(tol.deg, dig=3), " degrees (", round(tol.rad, dig=3), " radians)\n", sep=""))
      }
    }
  }
  else
    if(messages.screen)
      cat("variog: computing omnidirectional variogram\n")
  ##   
  ##
  coords <- as.matrix(coords)
  data <- as.matrix(data)
  data.var <- apply(data, 2, var)
  n.data <- nrow(coords)
  n.datasets <- ncol(data)
  if (ncol(data) == 1) 
    data <- as.vector(data)
  ##
  ## variogram estimator
  ##
  option <- match.arg(option)
  if (estimator.type == "robust") 
    estimator.type <- "modulus"
  estimator.type <- match.arg(estimator.type)
  if (estimator.type == "modulus") 
    estimator.type <- "robust"
  if (lambda != 1) {
    if (lambda == 0) 
      data <- log(data)
    else data <- ((data^lambda) - 1)/lambda
  }
  ##
  ## trend removal
  ##
  xmat <- trend.spatial(trend = trend, coords = coords)
  if (trend != "cte") {
    if (is.vector(data)) {
      data <- lm(data ~ xmat + 0)$residuals
      names(data) <- NULL
    }
    else {
      only.res <- function(y, x) {
        lm(y ~ x + 0)$residuals
      }
      data <- apply(data, 2, only.res, x = xmat)
    }
  }
  ##
  ## 
  ##
  u <- as.vector(dist(as.matrix(coords)))
  if(direction != "omnidirectional"){
    u.ang <- .C("tgangle",
                as.double(as.vector(coords[,1])),
                as.double(as.vector(coords[,2])),
                as.integer(dim(coords)[1]),
                res = as.double(rep(0, length(u))))$res
    u.ang <- atan(u.ang)
    u.ang[u.ang < 0] <- u.ang[u.ang < 0] + pi
  }
  if (option == "bin" & bin.cloud == FALSE & direction == "omnidirectional") {
    if (!is.null(max.dist)) 
      umax <- max(u[u < max.dist])
    else umax <- max(u)
    if (all(uvec == "default")) 
      uvec <- seq(0, umax, l = 12)
    if (is.numeric(uvec) & length(uvec) == 1) 
      uvec <- seq(0, umax, l = uvec)
    ubin <- c(0, uvec)
    nvec <- length(ubin)
    d <- 0.5 * diff(ubin[2:nvec])
    bins.lim <- c(0, (ubin[2:(nvec - 1)] + d), (d[nvec - 
                                                  2] + ubin[nvec]))
    if (uvec[1] == 0 & nugget.tolerance == 0) 
      uvec[1] <- (bins.lim[1] + bins.lim[2])/2
    if (nugget.tolerance > 0) {
      bins.lim <- c(0, nugget.tolerance, bins.lim[bins.lim > 
                                                  nugget.tolerance])
      uvec <- c(0, (bins.lim[-(1:2)] - 0.5 * diff(bins.lim)[-1]))
    }
    nbins <- length(bins.lim) - 1
    if (is.null(max.dist)) 
      max.dist <- max(bins.lim)
    bin.f <- function(data) {
      cbin <- vbin <- sdbin <- rep(0, nbins)
      result <- .C("binit", as.integer(n.data),
                   as.double(as.vector(coords[, 1])),
                   as.double(as.vector(coords[, 2])), as.double(as.vector(data)), 
                   as.integer(nbins), as.double(as.vector(bins.lim)), 
                   as.integer(estimator.type == "robust"), as.double(max.dist), 
                   cbin = as.integer(cbin), vbin = as.double(vbin), 
                   as.integer(TRUE), sdbin = as.double(sdbin))[c("vbin", 
                                       "cbin", "sdbin")]
    }
    result <- array(unlist(lapply(as.data.frame(data), bin.f)), 
                    dim = c(nbins, 3, n.datasets))
    indp <- (result[, 2, 1] >= pairs.min)
    result <- list(u = uvec[indp], v = result[indp, 1, ], 
                   n = result[indp, 2, 1], sd = result[indp, 3, ], bins.lim = bins.lim, 
                   ind.bin = indp)
  }
  else {
    if (is.matrix(data)) {
      v <- matrix(0, nrow = length(u), ncol = ncol(data))
      for (i in 1:ncol(data)) {
        v[, i] <- as.vector(dist(data[, i]))
        if (estimator.type == "robust") 
          v[, i] <- v[, i]^(0.5)
        else v[, i] <- (v[, i]^2)/2
      }
      if (!is.null(max.dist)) {
        v <- v[u <= max.dist, ]
        if(direction != "omnidirectional")
          u.ang <- u.ang[u <= max.dist]
        u <- u[u <= max.dist]
      }
      if(direction != "omnidirectional"){
        ang.ind <- ((u.ang >= ang.rad - tol.rad) & (u.ang <= ang.rad + tol.rad))
        v <- v[ang.ind,]
        u <- u[ang.ind]
      }
    }
    else {
      v <- as.vector(dist(data))
      if (estimator.type == "robust") 
        v <- v^(0.5)
      else v <- (v^2)/2
      if (is.numeric(max.dist)) {
        v <- v[u <= max.dist]
        if(direction != "omnidirectional")
          u.ang <- u.ang[u <= max.dist]
        u <- u[u <= max.dist]
      }
      if(direction != "omnidirectional"){
        ang.ind <- ((u.ang >= ang.rad - tol.rad) & (u.ang <= ang.rad + tol.rad))
        v <- v[ang.ind]
        u <- u[ang.ind]
      }
    }
    if (option == "cloud") {
      result <- list(u = u, v = v)
    }
    if (option == "bin") {
      if (!is.null(max.dist)) 
        umax <- max(u[u < max.dist])
      else umax <- max(u)
      keep <- list(...)
      if(is.null(keep$keep.NA)) keep.NA <- FALSE
      else keep.NA <- keep$keep.NA
      result <- rfm.bin(cloud = list(u = u, v = v),
                        estimator.type = estimator.type, 
                        uvec = uvec, nugget.tolerance = nugget.tolerance, 
                        bin.cloud = bin.cloud, max.dist = umax, keep.NA = keep.NA)
      if(keep.NA){
        if (pairs.min > 0) {
          indp <- (result$n < pairs.min)
          if (is.matrix(result$v)) {
            result$v[indp, ] <- NA
            result$sd[indp, ] <- NA
          }
          else {
            result$v[indp] <- NA
            result$sd[indp] <- NA
          }
        }
        result$ind.bin <- indp
      }
      else{
        if (pairs.min > 0) {
          indp <- (result$n >= pairs.min)
          if (is.matrix(result$v)) {
            result$v <- result$v[indp, ]
            result$sd <- result$sd[indp, ]
          }
          else {
            result$v <- result$v[indp]
            result$sd <- result$sd[indp]
          }
          result$u <- result$u[indp]
          result$n <- result$n[indp]
        }
        result$ind.bin <- indp
      }
    }
    if (option == "smooth") {
      if (is.R()) 
        require(modreg)
      if (is.matrix(v)) 
        stop("smooth not yet available for several variables")
      temp <- ksmooth(u, v, ...)
      result <- list(u = temp[[1]], v = temp[[2]])
    }
  }
  result <- c(result, list(var.mark = data.var, output.type = option, 
                           estimator.type = estimator.type, n.data = n.data,
                           lambda = lambda, trend = trend))
  result$nugget.tolerance <- nugget.tolerance
  if(direction != "omnidirectional") result$direction <- ang.rad
  else result$direction <- "omnidirectional"
  if(direction != "omnidirectional") result$tolerance <- tol.rad
  else result$tolerance <- "none" 
  result$uvec <- uvec
  result$call <- call.fc
  class(result) <- "variogram"
  return(result)
}

"variog4" <-
  function (geodata, coords = geodata$coords, data = geodata$data, 
            uvec = "default", trend = "cte", lambda = 1,
            option = c("bin", "cloud", "smooth"),
            estimator.type = c("classical", "modulus"), 
            nugget.tolerance = 0, max.dist = NULL, pairs.min = 2,
            bin.cloud = FALSE, direction = c(0, pi/4, pi/2, 3*pi/4), tolerance = pi/8,
            unit.angle = c("radians", "degrees"), messages.screen = TRUE, ...) 
{
  require(mva)
  u <- as.vector(dist(as.matrix(coords)))
  if(length(direction) != 4)
    stop("argument direction must be a vector with 4 values. For different specifications use the functio variog()")
  if(length(tolerance) != 1)
    stop("only 1 values can be provided to the argument tolerance . For different specifications use the functio variog()")
  res <- list()
  if(unit.angle == "radians")
    dg <- direction * 180/pi
  else dg <- direction
  if (!is.null(max.dist)) 
    umax <- max(u[u < max.dist])
  else umax <- max(u)
  if (all(uvec == "default")) 
    uvec <- seq(0, umax, l = 12)
  ubin <- c(0, uvec)
  nvec <- length(ubin)
  d <- 0.5 * diff(ubin[2:nvec])
  bins.lim <- c(0, (ubin[2:(nvec - 1)] + d), (d[nvec - 
                                                2] + ubin[nvec]))
  if (uvec[1] == 0 & nugget.tolerance == 0) 
    uvec[1] <- (bins.lim[1] + bins.lim[2])/2
  if (nugget.tolerance > 0) {
    bins.lim <- c(0, nugget.tolerance, bins.lim[bins.lim > 
                                                nugget.tolerance])
    uvec <- c(0, (bins.lim[-(1:2)] - 0.5 * diff(bins.lim)[-1]))
  }
  u <- NULL
  for(angle in direction){
    res[[as.character(round(dg[which(direction == angle)], dig=1))]] <-
      variog(coords=coords, data=data,
             uvec=uvec, trend = trend,
             lambda = lambda, option = option,
             estimator.type = estimator.type,
             nugget.tolerance = nugget.tolerance,
             max.dist = max.dist,
             pairs.min = pairs.min,
             bin.cloud = bin.cloud,
             direction = angle,
             tolerance = tolerance,
             unit.angle = unit.angle,
             messages.screen = TRUE, keep.NA = TRUE)
  }
  res$omnidirectional <- variog(coords=coords, data=data,
                                uvec=uvec, trend = trend,
                                lambda = lambda, option = option,
                                estimator.type = estimator.type,
                                nugget.tolerance = nugget.tolerance,
                                max.dist = max.dist,
                                pairs.min = pairs.min,
                                bin.cloud = bin.cloud,
                                direction = "omnidirectional",
                                tolerance = tolerance,
                                unit.angle = unit.angle,
                                messages.screen = TRUE,
                                keep.NA = TRUE 
                                )
  class(res) <- "variog4"
  return(res)
  
}

"plot.variog4" <-
  function (obj, omnidirectional = FALSE, same.plot = TRUE, legend = TRUE,...)
{
  ymax <- max(c(obj[[1]]$v, obj[[2]]$v, obj[[3]]$v, obj[[4]]$v), na.rm=T)
  n.o <- names(obj)[1:4]
  GP <- list(...)
  if(is.null(GP$xlab)) GP$xlab <- "distance"
  if(is.null(GP$ylab)) GP$ylab<- "semi-variance"
  if (same.plot) {
    xx <- obj[[5]]$u
    yy <- cbind(obj[[1]]$v, obj[[2]]$v, obj[[3]]$v, obj[[4]]$v)
    if (omnidirectional)
      yy <- cbind(obj[[5]]$v, yy)
    if (is.null(GP$lty))
      GP$lty <- 1:5
    if (is.null(GP$lwd))
      GP$lwd <- 1
    if (is.null(GP$col))
      GP$col <- 1:5
    if (is.null(GP$pch))
      GP$pch <- NULL
    if (is.null(GP$type))
      GP$type <- "l"
    matplot(x = xx, y = yy, type = GP$type, lty=GP$lty, lwd=GP$lwd, col=GP$col, pch=GP$pch, xlab=GP$xlab, ylab=GP$ylab, ylim=c(0,max(yy)))
    if (legend) {
      if (omnidirectional) {
        legend(0, ymax,
               legend = c("omnid.",
                 substitute(a * degree, list(a = n.o[1])),
                 substitute(a * degree, list(a = n.o[2])),
                 substitute(a * degree, list(a = n.o[3])),
                 substitute(a * degree, list(a = n.o[4])),
                 expression()),
               lty = GP$lty, lwd = GP$lwd, col = GP$col)
      }
      else {
        legend(0, ymax,
               legend = c(substitute(a * degree,
                 list(a = n.o[1])), substitute(a * degree, list(a = n.o[2])),
                 substitute(a * degree, list(a = n.o[3])), substitute(a *
                                               degree, list(a = n.o[4])), expression()),
               lty = GP$lty, lwd = GP$lwd, col = GP$col)
      }
    }
  }
  else {
    temp.mf <- par()$mfrow
    par(mfrow = c(2, 2))
    if (is.null(GP$lty)) {
      GP$lty <- rep(1, 4)
      if (omnidirectional)
        GP$lty <- c(GP$lty, 2)
    }
    else {
      if (length(GP$lty) == 1)
        if (omnidirectional)
          GP$lty <- rep(GP$lty, 5)
        else GP$lty <- rep(GP$lty, 4)
      if (length(GP$lty) == 2)
        if (omnidirectional)
          GP$lty <- c(rep(GP$lty[1], 4), GP$lty[2])
        else GP$lty <- c(rep(GP$lty, 4))
      if (length(GP$lty) == 4 & omnidirectional)
        GP$lty <- c(rep(GP$lty, 2))
    }
    if (is.null(GP$lwd)) {
      GP$lwd <- rep(1, 4)
      if (omnidirectional)
        GP$lwd <- c(GP$lwd, 1)
    }
    else {
      if (length(GP$lwd) == 1)
        if (omnidirectional)
          GP$lwd <- rep(GP$lwd, 5)
        else GP$lwd <- rep(GP$lwd, 4)
      if (length(GP$lwd) == 2)
        if (omnidirectional)
          GP$lwd <- c(rep(GP$lwd[1], 4), GP$lwd[2])
        else GP$lwd <- rep(GP$lwd, 4)
      if (length(GP$lwd) == 4 & omnidirectional)
        GP$lwd <- c(rep(GP$lwd, 1))
    }
    if (is.null(GP$col)) {
      GP$col <- rep(1, 4)
      if (omnidirectional)
        GP$col <- c(GP$col, 1)
    }
    else {
      if (length(GP$col) == 1)
        if (omnidirectional)
          GP$col <- rep(GP$col, 5)
        else GP$col <- rep(GP$col, 4)
      if (length(GP$col) == 2)
        if (omnidirectional)
          GP$col <- c(rep(GP$col[1], 4), GP$col[2])
        else GP$col <- rep(GP$col, 2)
      if (length(GP$col) == 4 & omnidirectional)
        GP$col <- c(rep(GP$col, 1))
    }
    if (is.null(GP$pch)) {
      GP$pch <- rep(1, 4)
      if (omnidirectional)
        GP$pch <- c(GP$pch, 1)
    }
    else {
      if (length(GP$pch) == 1)
        if (omnidirectional)
          GP$pch <- rep(GP$pch, 5)
        else GP$pch <- rep(GP$pch, 4)
      if (length(GP$pch) == 2)
        if (omnidirectional)
          GP$pch <- c(rep(GP$pch[1], 4), GP$pch[2])
        else GP$pch <- rep(GP$pch, 2)
      if (length(GP$pch) == 4 & omnidirectional)
        GP$pch <- c(rep(GP$pch, 2))
    }
    if (is.null(GP$type)) {
      GP$type <- rep("l", 4)
      if (omnidirectional)
        GP$type <- c(GP$type, "l")
    }
    else {
      if (length(GP$type) == 1)
        if (omnidirectional)
          GP$type <- rep(GP$type, 5)
        else GP$type <- rep(GP$type, 4)
      if (length(GP$type) == 2 & omnidirectional)
        GP$type <- c(rep(GP$type[1], 4), GP$type[2])
      if (length(GP$type) == 4 & omnidirectional)
        GP$type <- c(rep(GP$type, 2))
    }
    for (i in 1:4) {
      plot.default(obj[[i]]$u, obj[[i]]$v,
                   ylim = c(0, ymax), type = GP$type[i],
           col = GP$col[i], lwd = GP$lwd[i], lty = GP$lty[i],
           pch = GP$pch[i], xlab=GP$xlab, ylab=GP$ylab)
      if (omnidirectional) {
        lines(obj$omnidirectional, type = GP$type[5],
              col = GP$col[5], lwd = GP$lwd[5], lty = GP$lty[5])
        legend(0, ymax, legend = c(substitute(a * degree,
                          list(a = n.o[i])), "omn.", expression()),
               lty = c(GP$lty[i], GP$lty[5]),
               col=c(GP$col[i],  GP$col[5]),
               lwd=c(GP$lwd[i],  GP$lwd[5]))
      }
      else title(main = substitute(a * degree, list(a = n.o[i])),
                 cex = 1.3)
    }
    par(mfrow = temp.mf)
  }
  return(invisible())
}


"rfm.bin" <-
  function (cloud, l = 15, uvec = "default", nugget.tolerance = 0, 
            estimator.type = c("classical", "robust"), bin.cloud = FALSE,
            max.dist, keep.NA = FALSE)
{
  if (all(uvec == "default")) 
    uvec <- seq(0, max(cloud$u), l = l)
  estimator.type <- match.arg(estimator.type)
  ##  if(nugget.tolerance > 0) {
  ##    dnug <- mean(cloud$u[cloud$u <= nugget.tolerance])
  ##    cloud$u[cloud$u <= nugget.tolerance] <- 0
  ##    uvec <- uvec[uvec > nugget.tolerance]
  ##  }
  ##  u <- c(0, uvec)
  ##  n <- length(u)
  if(all(uvec == "default"))
    uvec <- seq(0, max.dist, l = 15)
  ubin <- c(0, uvec)
  nvec <- length(ubin)
  d <- 0.5 * diff(ubin[2:nvec])
  bins.lim <- c(0, (ubin[2:(nvec - 1)] + d), (d[nvec - 2] + ubin[
                                                                 nvec]))
  if(uvec[1] == 0 & nugget.tolerance == 0)
    uvec[1] <- (bins.lim[1] + bins.lim[2])/2
  if(nugget.tolerance > 0) {
    bins.lim <- c(0, nugget.tolerance, bins.lim[bins.lim >
                                                nugget.tolerance])
    uvec <- c(0, (bins.lim[ - (1:2)] - 0.5 * diff(bins.lim)[
                                                            -1]))
  }
  nbins <- nc <- length(bins.lim) - 1
  if(is.null(max.dist))
    max.dist <- max(bins.lim)
  min.dist <- min(cloud$u)
  ##	d <- 0.5 * (u[3:n] - u[2:(n - 1)])
  ##	low <- c(0, (u[2:(n - 1)] + d))
  ##	high <- c((u[3:n] - d), (d[n - 2] + u[n]))
  ##	nc <- n - 1
  if (!is.matrix(cloud$v)) {
    vbin <- rep(0, nc)
    nbin <- rep(0, nc)
    sdbin <- rep(0, nc)
    if (bin.cloud == TRUE) 
      bins.clouds <- list()
    for (i in 1:nc) {
      ind <- (cloud$u > bins.lim[i]) & (cloud$u <= bins.lim[i+1])
      vbin[i] <- mean(cloud$v[ind])
      if (bin.cloud == TRUE) 
        bins.clouds[[i]] <- cloud$v[ind]
      nbin[i] <- sum(ind)
      if (estimator.type == "robust") 
        vbin[i] <- ((vbin[i])^4)/(0.914 + (0.988/nbin[i]))
      if (nbin[i] > 0) 
        sdbin[i] <- sqrt(var(cloud$v[ind]))
      else sdbin[i] <- NA
      NULL
    }
    if (uvec[1] == 0) 
      uvec[1] <- (bins.lim[1] + bins.lim[2])/2
    if (min.dist == 0) {
      ind <- (cloud$u == 0)
      n.zero <- sum(ind)
      v.zero <- mean(cloud$v[ind])
      if (bin.cloud == TRUE) {
        bins.clouds[2:(length(bins.clouds) + 1)] <- bins.clouds[1:nc]
        bins.clouds[[1]] <- cloud$v[ind]
      }
      if (estimator.type == "robust") 
        v.zero <- ((v.zero)^4)/(0.914 + (0.988/n.zero))
      if (n.zero > 0) 
        sd.zero <- sqrt(var(cloud$v[ind]))
      else sd.zero <- NA
      uvec <- c(0, uvec)
      vbin <- c(v.zero, vbin)
      nbin <- c(n.zero, nbin)
      sdbin <- c(sd.zero, sdbin)
    }
    if(keep.NA == FALSE){
      u <- uvec[!is.na(vbin)]
      v <- vbin[!is.na(vbin)]
      n <- nbin[!is.na(vbin)]
      sd <- sdbin[!is.na(vbin)]
    }
    else{
      u <- uvec
      v <- vbin
      n <- nbin
      sd <- sdbin
    }
    if (bin.cloud == TRUE) 
      bins.clouds <- bins.clouds[!is.na(vbin)]
  }
  else {
    if (bin.cloud == TRUE) 
      stop("option bins.cloud=T allowed only for 1 variable")
    nvcols <- ncol(cloud$v)
    vbin <- matrix(0, nrow = nc, ncol = nvcols)
    nbin <- rep(0, nc)
    sdbin <- matrix(0, nrow = nc, ncol = nvcols)
    for (i in 1:nc) {
      ind <- (cloud$u >= bins.lim[i]) & (cloud$u < bins.lim[i+1])
      nbin[i] <- sum(ind)
      for (j in 1:nvcols) {
        vbin[i, j] <- mean(cloud$v[ind, j])
        if (estimator.type == "robust") 
          vbin[i, j] <- ((vbin[i, j])^4)/(0.914 + (0.988/nbin[i]))
        if (nbin[i] > 0) 
          sdbin[i, j] <- sqrt(var(cloud$v[ind, j]))
        else sdbin[i, j] <- NA
      }
      NULL
    }
    if (uvec[1] == 0) 
      uvec[1] <- (bins.lim[1] + bins.lim[2])/2
    if (min.dist == 0) {
      v.zero <- rep(0, nvcols)
      n.zero <- rep(0, nvcols)
      sd.zero <- rep(0, nvcols)
      for (j in 1:nvcols) {
        ind <- (cloud$u == 0)
        n.zero[j] <- sum(ind)
        v.zero[j] <- mean(cloud$v[ind, j])
        if (estimator.type == "robust") 
          v.zero[j] <- ((v.zero[j])^4)/(0.914 + (0.988/n.zero[j]))
        if (n.zero[j] > 0) 
          sd.zero[j] <- sqrt(var(cloud$v[ind, j]))
        else sd.zero[j] <- NA
        uvec <- c(0, uvec)
        vbin <- rbind(v.zero, vbin)
        nbin <- c(n.zero, nbin)
        sdbin <- rbind(sd.zero, sdbin)
      }
    }
    if(keep.NA == FALSE){
      u <- uvec[!is.na(vbin[, 1])]
      n <- nbin[!is.na(vbin[, 1])]
      v <- matrix(0, nrow = length(u), ncol = nvcols)
      sd <- matrix(0, nrow = length(u), ncol = nvcols)
    }
    else{
      u <- uvec
      n <- nbin
      v <- matrix(0, nrow = length(u), ncol = nvcols)
      sd <- matrix(0, nrow = length(u), ncol = nvcols)
    }
    for (j in 1:nvcols) {
      if(keep.NA == FALSE){
        v[, j] <- vbin[!is.na(vbin[, j]), j]
        sd[, j] <- sdbin[!is.na(vbin[, j]), j]
      }
      else{
        v[, j] <- vbin[, j]
        sd[, j] <- sdbin[, j]
      }
    }
  }
  if (nugget.tolerance > 0) {
    u[1] <- nugget.tolerance
  }
  result <- list(u = u, v = v, n = n, sd = sd, output.type = "bin", bins.lim = bins.lim)
  if (!is.matrix(cloud$v) && bin.cloud == TRUE) 
    result$bin.cloud <- bins.clouds
  if (!is.null(class(cloud))) 
    class(result) <- class(cloud)
  return(result)
}

"plot.variogram" <-
  function (obj, max.dist, vario.col = "all", scaled = FALSE,  
            var.lines = FALSE,  envelope.obj = NULL,
            bin.cloud = FALSE,  ...) 
{
  if(missing(max.dist)) max.dist <- max(obj$u)
  Ldots <- list(...)
  if(is.null(Ldots$xlab)) Ldots$xlab <- "distance"
  if(is.null(Ldots$ylab)) Ldots$ylab <- "semi-variance"
  if(is.null(Ldots$ty)){
    if (obj$output.type == "bin") Ldots$type <- "b"
    if (obj$output.type == "smooth") Ldots$type <- "l"
    if (obj$output.type == "cloud") Ldots$type <- "p"
  }
 if (bin.cloud == TRUE &&  Ldots$type != "b") 
    stop("plot.variogram: object must be a binned variogram with option bin.cloud=T")
  if (bin.cloud == TRUE && all(is.na(obj$bin.cloud))) 
    stop("plot.variogram: object must be a binned variogram with option bin.cloud=T")
  if (bin.cloud == TRUE && any(!is.na(obj$bin.cloud))) 
    boxplot(obj$bin.cloud, varwidth = TRUE, 
            xlab = "midpoints of distance class",
            ylab = paste("variogram values / ", 
              obj$estimator.type, "estimator"))
  else {
    u <- obj$u[obj$u <= max.dist]
    v <- obj$v
    if(is.vector(v) | length(v) == length(obj$u))
      v <- matrix(v, ncol=1)
    v <- v[obj$u <= max.dist,, drop=FALSE]
    if(vario.col == "all")
      vario.col <- 1:dim(v)[2]
    else
      if(!is.numeric(vario.col) | any(vario.col > ncol(v)))
        stop("argument vario.col must be equals to \"all\" or a vector indicating the column numbers to be plotted")
    v <- v[, vario.col, drop=F]
    if (scaled)
      v <- t(t(v)/obj$var.mark[vario.col])
    if (is.null(Ldots$ylim)){
      ymax <- max(v)
      if (!is.null(envelope.obj)) 
        ymax <- max(c(envelope.obj$v.upper, ymax))
      Ldots$ylim <- c(0, ymax)
    }
    if(ncol(v) == 1){
      v <- as.vector(v)
      plot(x= u, y= v, xlim = c(0, max.dist), ylim = Ldots$ylim, 
           xlab = Ldots$xlab, ylab = Ldots$ylab, type = Ldots$type)
    }
    else
      matplot(x=u, y= v, xlim = c(0, max.dist), ylim = Ldots$ylim, 
           xlab = Ldots$xlab, ylab = Ldots$ylab, type = Ldots$type)
    if (var.lines) {
      if (scaled) abline(h = 1, lty = 3)
      else abline(h = obj$var.mark, lty = 3)
    }
    if (!is.null(envelope.obj)) {
      lines(u, envelope.obj$v.lower, lty = 4)
      lines(u, envelope.obj$v.upper, lty = 4)
    }
  }
  return(invisible())
}

"lines.variogram" <-
function (obj, max.dist, type = "o", scaled = FALSE, ...) 
{
  if(missing(max.dist)) max.dist <- max(obj$u)
  if (scaled) 
    obj$v <- obj$v/obj$var.mark
  if (!is.matrix(obj$v)) 
    lines(obj$u[obj$u <= max.dist], obj$v[obj$u <= max.dist], 
          type = type, ...)
  else {
    for (j in 1:ncol(obj$v)) lines(obj$u[obj$u <= max.dist], 
                                   obj$v[obj$u <= max.dist, j], type = type, ...)
  }
}
##
## "wrappers" for pieces of C code used in geoR/geoS
##
bilinearformXAY <-
  function(X, lowerA, diagA, Y)
  {
    nA <- length(diagA)
    nX <- length(X)/nA
    nY <- length(Y)/nA
    if(length(lowerA) != (nA * (nA -1)/2))
      stop("lowerA and diagA have incompatible dimentions")
    out <- .C("bilinearform_XAY",
              as.double(as.vector(lowerA)),
              as.double(as.vector(diagA)),
              as.double(as.vector(X)),
              as.double(as.vector(Y)),
              as.integer(nX),
              as.integer(nY),
              as.integer(nA),
              res=as.double(rep(0,(nX*nY))))$res
    attr(out, "dim") <- c(nX, nY)
    return(out)
  }

diagquadraticformXAX <-
  function(X, lowerA, diagA)
  {
    nA <- length(diagA)
    nX <- length(X)/nA
    if(length(lowerA) != (nA * (nA -1)/2))
      stop("lowerA and diagA have incompatible dimentions")
    out <- .C("diag_quadraticform_XAX",
              as.double(as.vector(lowerA)),
              as.double(as.vector(diagA)),
              as.double(as.vector(X)),
              as.integer(nX),
              as.integer(nA),
              res = as.double(rep(0,nX)))$res
    return(out)
  }

loccoords <-
  function(coords, locations)
  {
    ## Computes a matrix for which each row has the distances between
    ## each point in 'locations' to all the points in 'coords'
    coords <- as.matrix(coords)
    locations <- as.matrix(locations)
    dimc <- dim(coords)
    diml <- dim(locations)
    if((dimc[2] != 2) | (diml[2] != 2))
      stop("coords and locations must have two columns")
    nc <- dimc[1]
    nl <- diml[1]
    out <- as.double(rep(0, nc*nl))
    .C("loccoords",
       as.double(as.vector(locations[,1])),
       as.double(as.vector(locations[,2])),
       as.double(as.vector(coords[,1])),
       as.double(as.vector(coords[,2])),
       as.integer(nl),
       as.integer(nc),
       out, DUP=FALSE)
    attr(out, "dim") <- c(nc, nl)
    return(out)
  }

distdiag <-
  function(coords)
  {
    ## returns the lower triangle of the matrix with euclidean distances
    ## between pairs of points, including the diagonal. 
    ##
    coords <- as.matrix(coords)
    dimc <- dim(coords)
    if(dimc[2] == 1 & dimc[1] == 2)
      return(0)
    else{
      if(dimc[2] != 2)
        stop("coords must have two columns")
      nc <- dimc[1]
      out <- as.double(rep(0, (nc * (nc+1)/2)))
      .C("distdiag",
         as.double(coords[,1]),
         as.double(coords[,2]),
         as.integer(nc),
         out, DUP = FALSE)
      return(out)
    }
  }













"xvalid" <-
  function (geodata, coords = geodata$coords, data = geodata$data, 
            model, reestimate = FALSE, variog.obj = NULL,
            output.reestimate = FALSE, locations.xvalid = "all",
            data.xvalid = NULL, messages.screen = TRUE, ...) 
{
  n <- nrow(coords)
  data <- as.vector(data)
  if (length(data) != n) 
    stop("coords and data have incompatible dimentions")
  xmat <- trend.spatial(trend = model$trend, coords = coords)
  ##
  ## Locations to be used in the cross-validation
  ##
  if(all(locations.xvalid == "all") | is.vector(locations.xvalid)){
    if(locations.xvalid == "all")
      locations.xvalid <- 1:n
    else
      if(any(locations.xvalid > n) | !is.numeric(locations.xvalid))
        stop("\nxvalid: vector indicating locations to be validated is not a numeric vector and/or has element(s) with value greater than the number of data loccations")
    crossvalid <- TRUE
  }
  else{
    if(is.matrix(locations.xvalid) | is.data.frame(locations.xvalid))
      if(dim(locations.xvalid)[2] <= 2){
        if(dim(locations.xvalid)[2] == 1){
          locations.xvalid <- is.vector(locations.xvalid)
          crossvalid <- TRUE
          if(any(locations.xvalid) > n | length(locations.xvalid) > n)
            stop("incorrect value to the argument locations.xvalid.\nThis must be a numeric vector with numbers indicating the locations to be cross-validated")
        }
        else{
          if(messages.screen)
            cat("xvalid: cross-validation to be performed on locations provided by the user\n")
          if(is.null(data.xvalid))
            stop("the argument \"data.xvalid\" must be provided in order to perform validation on a set of locations different from the original data")
          crossvalid <- FALSE
        }
      }
      else
        if(!is.vector(locations.xvalid) | !is.numeric(locations.xvalid))
          stop("\nargument locations.xvalid must be either:\n a numeric vector with numbers indicating the locations to be cross-validated\n a matrix with coordinates for the locations to be cross-validated.")
        else
          if(any(locations.xvalid) > n | length(locations.xvalid) > n)
            stop("incorrect value to the argument locations.xvalid.\nThis must be a numeric vector with numbers indicating the locations to be cross-validated")
  }
  if(crossvalid == FALSE) n.pt.xv <- dim(locations.xvalid)[[1]]
  else n.pt.xv <- length(locations.xvalid)
  if(messages.screen){
    cat(paste("xvalid: number of data locations       =", n))
    cat("\n")
    cat(paste("xvalid: number of validation locations =", n.pt.xv))
    cat("\n")
    if(crossvalid) cat("xvalid: performing cross-validation at location ... ")
    else  cat("xvalid: performing validation at the locations provided")
    }
  ##
  ## Defining a function to predict at one point
  ##
  if(crossvalid){
    cv.f <- function(ndata, ...) {
      if(messages.screen) cat(paste(ndata, ", ", sep=""))
      ## excluding data point
      coords.out <- coords[ndata, , drop = FALSE]
      data.out <- data[ndata]
      xmat.out <- xmat[ndata, , drop = FALSE]
      cv.coords <- coords[-ndata, ]
      cv.data <- as.vector(data)[-ndata]
      cv.xmat <- xmat[-ndata, , drop = FALSE]
      ## re-estimating the model
      if (reestimate) {
        if(model$method == "ML" | model$method == "REML" | model$method == "RML"){
          fix.pars <- (model$parameters.summary[c("tausq", "kappa", "psiA",
                                                  "psiR", "lambda"), 1] == "fixed")
          val.pars <- model$parameters.summary[c("tausq", "kappa", 
                                                 "psiA", "psiR", "lambda"), 2]
          names(fix.pars) <- c("tausq", "kappa", "psiA", "psiR", 
                               "lambda")
          names(val.pars) <- c("tausq", "kappa", "psiA", "psiR", 
                               "lambda")
          CVmod <- likfit(coords = cv.coords, data = cv.data, 
                          ini = model$cov.pars, fix.nugget = fix.pars["tausq"], 
                          nugget = val.pars["tausq"], fix.kappa = fix.pars["kappa"], 
                          kappa = val.pars["kappa"], fix.psiR = fix.pars["psiR"], 
                          psiR = val.pars["psiR"], fix.psiA = fix.pars["psiA"], 
                          psiA = val.pars["psiA"], fix.lambda = fix.pars["lambda"], 
                          lambda = val.pars["lambda"], cov.model = model$cov.model, 
                          trend = ~cv.xmat + 0, method = model$method, 
                          messages.screen = F, ...)
          if(output.reestimate){
            CVpars <- (CVmod$parameters.summary[c("tausq", "kappa", "psiA", "psiR", "lambda"), 2])
            CVpars <- c(CVmod$cov.pars, CVpars[fix.pars == FALSE])
          } 
        }
        if(model$method == "OLS" | model$method == "WLS"){
          if(is.null(variog.obj))
            stop("xvalid: when argument reestimate = TRUE an object with the fitted variogram model must be provided in the argument variog.obj ")
          CVvar <- variog(coords = cv.coords, data = cv.data, uvec = variog.obj$uvec,
                          trend = variog.obj$trend, lambda = variog.obj$lambda,
                          option = variog.obj$output.type,
                          estimator.type = variog.obj$estimator.type,
                          nugget.tolerance = variog.obj$nugget.tolerance,
                          max.dist = max(variog.obj$u), pairs.min = 2,
                          bin.cloud = FALSE, direction = variog.obj$direction,
                          tolerance = variog.obj$tolerance,
                          unit.angle = "radians",
                          messages.screen = FALSE, ...)
          CVmod <- variofit(vario = CVvar, ini=model$cov.pars, cov.model = model$cov.model,
                            fix.nugget = model$fix.nugget, nugget = model$nugget,
                            fix.kappa = model$fix.kappa, kappa = model$kappa, max.dist = model$max.dist,
                            minimisation.function = model$minimisation.function,
                            weights = model$weights, messages.screen = FALSE, ...)
          if(output.reestimate){
            CVpars <- CVmod$cov.pars
            if(CVmod$fix.nugget == FALSE) CVpars <- c(CVpars, CVmod$nugget)
            if(CVmod$fix.kappa == FALSE) CVpars <- c(CVpars, CVmod$kappa)
          }
        }
      }
      else CVmod <- model
      if(model$method == "ML" | model$method == "REML" | model$method == "RML"){
        fix.pars <- (CVmod$parameters.summary[c("tausq", "kappa", 
                                                "psiA", "psiR", "lambda"), 1] == "fixed")
        val.pars <- CVmod$parameters.summary[c("tausq", "kappa", 
                                               "psiA", "psiR", "lambda"), 2]
      }
      if(model$method == "OLS" | model$method == "WLS"){
        fix.pars <- c(CVmod$fix.nugget, CVmod$fix.kappa,T,T,T)
        if(is.null(CVmod$kappa)) CVmod$kappa <- 0.5
        val.pars <- c(CVmod$nugget, CVmod$kappa, 0, 1, CVmod$lambda)
      }
      names(fix.pars) <- c("tausq", "kappa", "psiA", "psiR", "lambda")
      names(val.pars) <- c("tausq", "kappa", "psiA", "psiR", "lambda")
      kr <- krige.conv(coords = cv.coords, data = cv.data, loc = coords.out,
                       krige = krige.control(trend.d = ~cv.xmat + 0,
                         trend.l = ~xmat.out + 0, cov.model = CVmod$cov.model, 
                         cov.pars = CVmod$cov.pars, nugget = CVmod$nugget, 
                         kappa = val.pars["kappa"], lambda = val.pars["lambda"], 
                         aniso.pars = val.pars[c("psiA", "psiR")]), mess = FALSE)
      res <- c(data.out, kr$pred, kr$krige.var)
      if(output.reestimate) res <- c(res, CVpars)
      ##, err = (data.out - kr$pred), e.rel = (data.out - kr$pred)/sqrt(kr$krige.var), 
      ##pval = pnorm(data.out, mean = kr$pred, sd = sqrt(kr$krige.var)))
      return(res)
    }
    res <- as.data.frame(t(apply(matrix(locations.xvalid), 1, cv.f)))
  }
  else{
    xmat.val.loc <- trend.spatial(trend = model$trend, coords = locations.xvalid)
    if(model$method == "ML" | model$method == "REML" | model$method == "RML"){
      fix.pars <- (model$parameters.summary[c("tausq", "kappa", 
                                              "psiA", "psiR", "lambda"), 1] == "fixed")
      val.pars <- model$parameters.summary[c("tausq", "kappa", 
                                             "psiA", "psiR", "lambda"), 2]
    }
    if(model$method == "OLS" | model$method == "WLS"){
      fix.pars <- c(model$fix.nugget, model$fix.kappa,T,T,T)
      if(is.null(model$kappa)) model$kappa <- 0.5
      val.pars <- c(model$nugget, model$kappa, 0, 1, model$lambda)
    }
    names(fix.pars) <- c("tausq", "kappa", "psiA", "psiR", "lambda")
    names(val.pars) <- c("tausq", "kappa", "psiA", "psiR", "lambda")
    res <- krige.conv(coords = coords, data = data, loc = locations.xvalid,
                     krige = krige.control(trend.d = ~xmat + 0,
                       trend.l = ~xmat.val.loc + 0, cov.model = model$cov.model, 
                       cov.pars = model$cov.pars, nugget = model$nugget, 
                       kappa = val.pars["kappa"], lambda = val.pars["lambda"], 
                       aniso.pars = val.pars[c("psiA", "psiR")]), mess = FALSE)[1:2]
    res <- data.frame(data.xvalid, res$pred, res$krige.var)
  } 
  if(messages.screen) cat("\nxvalid: end of cross-validation\n")
  if(output.reestimate){
    pars.names <- c("sigmasq", "phi")
    if(model$method == "ML" | model$method == "REML" | model$method == "RML"){
      fix.pars <- (model$parameters.summary[c("tausq", "kappa", 
                                              "psiA", "psiR", "lambda"), 1] == "fixed")
      pars.names <- c(pars.names,(c("tausq", "kappa", "psiA", "psiR", "lambda"))[fix.pars == FALSE])
    }
    if(model$method == "OLS" | model$method == "WLS"){
      if(model$fix.nugget == FALSE) pars.names <- c(pars.names, "tausq")
      if(model$fix.kappa == FALSE) pars.names <- c(pars.names, "kappa")
    }
      names(res) <- c(c("data", "predicted", "krige.var"), pars.names)
  }
  else names(res) <- c("data", "predicted", "krige.var")
  res$error <- res$data - res$pred
  res$std.error <- res$err/sqrt(res$krige.var)
  res$prob <- pnorm(res$data, mean = res$pred, sd = sqrt(res$krige.var))
  if(output.reestimate){
    np <- length(pars.names)
    res <- res[,c((1:3), ((3+np+1):(6+np)),(4:(3+np)))] 
  }
  attr(res,"row.names") <- NULL
  attr(res, "class") <- "xvalid"
  return(res)
}

"plot.xvalid" <-
  function (obj, valid.obj, coords=valid.obj$coords, 
            error.plots = TRUE, std.error.plots = TRUE,
            borders = NULL, ask = TRUE)
{
  ##
  ## Saving original par() parameters
  ##
  if (is.R()) 
    par.ori <- par(no.readonly = TRUE)
  else par.ori <- par()
  on.exit(par(par.ori))
  ##
  ## checking input
  ##
  if(!is.null(borders)){
    if(!is.matrix(borders) & !is.data.frame(borders))
      stop("argument borders must be a two column matrix or a data frame with the coordinates of the borders")
    else
      if(ncol(borders) > 2)
        stop("argument borders must be a two column matrix or a data frame with the coordinates of the borders")
      else borders <- as.matrix(borders)
  }
  ##
  ## auxiliary computations for plots
  ##
  n <- length(obj$data)
  xylim <- range(c(obj$data, obj$pred))
  prelim <- range(obj$pred)
  datlim <- range(obj$data)
  errlim <- max(abs(range(obj$error)))
  errlim <- c(-errlim, errlim)
  err.std <- sqrt(var(obj$error))
  if(n > 90){
    seqerr <- seq(-3.5*err.std, 3.5*err.std, l=15)
    seqstd <- seq(-3.5, 3.5, l=15)
  }
  else{
    seqerr <- seq(-4*err.std, 4*err.std, l=9)
    seqstd <- seq(-4, 4, l=9)
  }
  stdlim <- max(c(3, abs(range(obj$std.error))))
  stdlim <- c(-stdlim, stdlim)
  # indicator for negative and positive errors
  error.cut <- cut(obj$error, breaks=c(errlim[1], 0, errlim[2]), include.l=TRUE, labels=FALSE)
  ##
  ## Data vs predicted
  ##
  par(pty = "s")
  plot(obj$data, obj$pred, type = "n", xlim = xylim, ylim = xylim,
       xlab = "data", ylab = "predicted")
  points(obj$data, obj$pred, pch = (c("x", "+"))[error.cut], col=(c("red", "blue"))[error.cut])
  abline(0,1)
  ##
  ##
  ##
  par(ask = ask)
  ##
  if(!error.plots | !std.error.plots){
    ##
    ## P-P plot
    ##
    par(pty = "s")  
    plot(ppoints(n), obj$prob[order(obj$prob)], xlim=c(0,1), ylim=c(0,1), xlab="theoretical prob", ylab="observed prob")
    abline(0,1)
  }
  if(error.plots){
    ##
    ## Plotting errors
    ##
    ## sizes proportional to errors values
    err.abs <- abs(obj$error)
    coords.order <- coords[order(err.abs), ]
    err.order <- err.abs[order(err.abs)]
    cut.order <- error.cut[order(err.abs)]
    r.y <- range(err.order)
    err.size <- 0.7 + ((err.order - r.y[1]) * (2 - 0.7))/(r.y[2] - r.y[1])
    ## equal scale for plot
    coords.lims <- apply(coords, 2, range)
    coords.diff <- diff(coords.lims)
    if (coords.diff[1] != coords.diff[2]) {
      coords.diff.diff <- abs(diff(as.vector(coords.diff)))
      ind.min <- which(coords.diff == min(coords.diff))
      coords.lims[, ind.min] <- coords.lims[, ind.min] + c(-coords.diff.diff, 
                                                           coords.diff.diff)/2
    }
    par(pty = "s")
    ##
    plot(coords, xlab = "Coord X", ylab = "Coord Y", type = "n", 
         xlim = coords.lims[, 1], ylim = coords.lims[, 2])
    if (is.R()) {
      points(coords.order, pch = (c("x", "+"))[cut.order], col=(c("red", "blue"))[cut.order], cex = err.size)
    }
    else
      points(coords.order, pch = (c("x", "+"))[cut.order], col=(c(3, 4))[cut.order], cex = err.size)
    if(!is.null(borders))
      lines(borders)
    ##
    ## errors histogram
    ##
    par(pty = "m")
    if(min(obj$error) < min(seqerr)) seqerr <- c(min(obj$error), seqerr)
    if(max(obj$error) > max(seqerr)) seqerr <- c(seqerr, max(obj$error))
    hist(obj$error, prob=T, main="", breaks=seqerr, xlab="data - predicted")
    ##
    ## errors vs predicted
    ##
    par(pty = "m")
    plot(obj$pred, obj$error, type = "n", xlim = prelim, ylim = errlim,
         xlab = "predicted", ylab = "data - predicted")
    points(obj$pred, obj$error, pch = (c("x", "+"))[error.cut], col=(c("red", "blue"))[error.cut])
    abline(h=0)
    ##
    ## errors vs data
    ##
    par(pty = "m")
    plot(obj$data, obj$error, type = "n", xlim = datlim, ylim = errlim,
         xlab = "data", ylab = "data - predicted")
    points(obj$data, obj$error, pch = (c("x", "+"))[error.cut], col=(c("red", "blue"))[error.cut])
    abline(h=0)
    ##
  }
  if(error.plots & std.error.plots){
    ##
    ## P-P plot
    ##
    par(pty = "s")  
    plot(ppoints(n), obj$prob[order(obj$prob)], xlim=c(0,1), ylim=c(0,1), xlab="theoretical prob", ylab="observed prob")
    abline(0,1)
  }
  if(std.error.plots){
    ##
    ## Plotting std errors
    ##
    ## sizes proportional to errors values
    err.abs <- abs(obj$std.error)
    coords.order <- coords[order(err.abs), ]
    err.order <- err.abs[order(err.abs)]
    cut.order <- error.cut[order(err.abs)]
    r.y <- range(err.order)
    err.size <- 0.7 + ((err.order - r.y[1]) * (2 - 0.7))/(r.y[2] - r.y[1])
    ## equal scale for plot
    coords.lims <- apply(coords, 2, range)
    coords.diff <- diff(coords.lims)
    if (coords.diff[1] != coords.diff[2]) {
      coords.diff.diff <- abs(diff(as.vector(coords.diff)))
      ind.min <- which(coords.diff == min(coords.diff))
      coords.lims[, ind.min] <- coords.lims[, ind.min] + c(-coords.diff.diff, 
                                                           coords.diff.diff)/2
    }
    par(pty = "s")
    ##
    plot(coords, xlab = "Coord X", ylab = "Coord Y", type = "n", 
         xlim = coords.lims[, 1], ylim = coords.lims[, 2])
    if (is.R()) {
      points(coords.order, pch = (c("x", "+"))[cut.order], col=(c("red", "blue"))[cut.order], cex = err.size)
    }
    else
      points(coords.order, pch = (c("x", "+"))[cut.order], col=(c(3, 4))[cut.order], cex = err.size)
    if(!is.null(borders))
      lines(borders)
    ##
    ## std. errors histogram
    ##
    par(pty = "m")
    if(min(obj$std.error) < min(seqstd)) seqstd <- c(min(obj$std.error), seqstd)
    if(max(obj$std.error) > max(seqstd)) seqstd <- c(seqstd, max(obj$std.error))
    hist(obj$std.error, prob=T, main="", breaks = seqstd, xlab="std error")
    ##
    ## std. errors vs predicted
    ##
    par(pty = "m")
    plot(obj$pred, obj$std.error, type = "n", xlim = prelim, ylim = stdlim,
         xlab = "predicted", ylab = "std error")
    points(obj$pred, obj$std.error, pch = (c("x", "+"))[error.cut], col=(c("red", "blue"))[error.cut])
    abline(h=0)
    ##
    ## std. errors vs data
    ##
    par(pty = "m")
    plot(obj$data, obj$std.error, type = "n", xlim = datlim, ylim = stdlim,
         xlab = "data", ylab = "std error")
    points(obj$data, obj$std.error, pch = (c("x", "+"))[error.cut], col=(c("red", "blue"))[error.cut])
    abline(h=0)
    ##
  }
  ##
  return(invisible())
}
".First.lib" <-
  function(lib, pkg)
{
  library.dynam("geoR", package = pkg, lib.loc = lib)  
  cat("\n")
  cat("------------------------------------------------\n")
  cat("geoR: a package for geostatistical analysis in R\n")
  cat("geoR is now loaded\n")
  cat("------------------------------------------------\n")
  cat("\n")
  cat("\n")
}

