Commit 82767c40 authored by alge's avatar alge

erster durchlauf ohne crash seit 1 jahr!!

nur fuer trend=0. .Package="baykrig" war der Uebeltaeter.

immer noch crash bei Free fuer trend=1
parent fa85a3a9
......@@ -135,164 +135,6 @@ check.krigedata <- function(point.obj,at,var.mod.obj,mode){
list(n=n)
}
#bk.grid <- function(point.obj,
# at,
# prior,
# var.mod.obj,
# xsw=NULL,ysw=NULL,xne=NULL,yne=NULL,
# dx=NULL,dy=NULL,nx=NULL,ny=NULL,
# angle=NULL,
# maxdist = NULL,
# extrap = F,
# border=NULL,
# trend=0,
# rsearch=0,
# nsearch=0,
# nsmin=-1,
# nsmax=-1,
# mode=3,
# duplicate = "error",
# dupfun = NULL,
# method="gqr")
# {
# tmp <- check.gridparams(angle,xsw,xne,ysw,yne,
# dx,dy,nx,ny)
# angle <- tmp$angle
# xsw <- tmp$xsw
# xne <- tmp$xne
# ysw <- tmp$ysw
# ysw <- tmp$ysw
# dx <- tmp$dx
# dy <- tmp$dy
# nx <- tmp$nx
# ny <- tmp$ny
# nx <- tmp$nx
#
# dog <- check.border(extrap,xsw,xne,ysw,yne,nx,ny,border,point.obj)
#
# tmp <- check.searchparams(maxdist,rsearch,nsearch,nsmin,nsmax,n)
# rsearch <- tmp$rsearch
# nsmin <- tmp$nsmin
# nsmax <- tmp$nsmax
#
# point.obj <- remove.duplicates(point.obj,at,duplicate,dupfun)
# tmp <- check.krigedata(point.obj,at,var.mod.obj)
# n <- tmp$n
#
# if(trend==0) ntrend<-1
# if(trend==1) ntrend<-3
# if(trend==2) ntrend<-6
#
# if(prior$ntr!=ntrend)
# stop("model order of priors does not match!")
#
# covtype<-switch(attr(var.mod.obj,"type"),
# exponential=1,
# gaussian=2,
# spherical=3,
# linear=4,
# 0)
# cov0<-0
# covmat<-matrix(0,n,n)
#
# snbbit<-rep(0,1+n*nz)
# snbbit[1]<-1
#
## determine optimum array sizes:
# if(!is.null(method)){
# if(method!="gqr" && method!="direct" && method!="ols")
# stop("method (used for glsfit) should be one of \"gqr\", \"ols\" or \"direct\"!")
# } else {
# method <-"gqr"
# }
# method<-switch(method,direct=2,gqr=1,ols=0)
#
# lwork <- glsfit.workquery(n,ntrend,method)
#
# npr<-prior$n
# typpr<-prior$info
# typpr[prior$type=="subjective"]<-typpr[prior$type=="subjective"]*(-1)
#
## prepare concatenated fortran arguments to avoid 65 parameter limit:
## DATVEC=XSW+YSW+XNE+YNE+ANGLE+DX+DY+LON+LAT+Z
## length= 1 1 1 1 1 1 1 N N N
# datvec<-c(xsw,ysw,xne,yne,angle,dx,dy,point.obj$x,point.obj$y,at)
#
# oldat<-at
# at <- point.obj[[match(at, names(point.obj))]]
# n <- length(point.obj$x)
# remove.duplicates()
## DBLVEC=XG+YG+ muwrk beta errbeta dev errdev zsrnb dist work ferr berr
## length=NX+NY+ ntrend+ntrend +1 +n +1 +n +n +lwork +n +n
# dblvec<-double(nx+ny+ntrend+ntrend+1+n+1+n+n+lwork+n+n)
#
## INTVEC=NX NY NZ EXTRAP N COVTYPE TREND NTREND NPR TYPPR NSEARCH NSMIN
## length= 1 1 1 1 1 1 1 1 1 npr 1 1
## NSMAX INDSNB INDSNW INDSRT LWORK IPVT IPIV IWORK MODE GLSMTH
## ... 1 n n n 1 ntrend n+ntrend 3*n 1 1
## ... BITS
## ... nz+nz*n+1 (pos nz+1=usesnbbit)
# intvec<-c(nx,nx,nz,extrap,n,covtype,trend,ntrend,npr,typpr,nsearch,nsmin,
# nsmax,integer(n),integer(n),integer(n),lwork,integer(ntrend),
# integer(n+ntrend),integer(3*n),mode,method,
# as.integer(c(integer(nz),as.integer(snbbit))))
#
# ans<-.Fortran("bkgrid",
# covmat = as.double(covmat),
# ldcov = as.integer(n),
# c0vec = double(n),
# cov0 = as.double(cov0),
# mupr = as.double(matlist.cbind(prior$mu)),
# ldmpr = as.integer(ntrend),
# phipr = as.double(matlist.cbind(prior$phi)),
# ldphpr = as.integer(ntrend),
## prinv = as.double(matlist.cbind(prior$phiinv)),
## ldpriv = as.integer(ntrend),
# phiwrk = double(ntrend*ntrend),
# ldphwk = as.integer(ntrend),
# lonpr = as.double(prior$lon),
# latpr = as.double(prior$lat),
# covbta = double(ntrend*ntrend),
# ldcvbt = as.integer(ntrend),
# cvsrnb = double(n*n),
# rsearch = as.double(rsearch),
# fwork = double(n*ntrend),
# fwork2 = double(n*ntrend),
# ldfwrk = as.integer(n),
# f0work = double(ntrend),
# kwork = double(n*n),
# ldkwrk = as.integer(n),
# rhswork = double(n),
# fpwork = double(n*ntrend),
# fpfwork = double(n*n),
# fpf0wrk = double(n),
# chlup = double(n*n),
# ldclup = as.integer(n),
# cminv = double(n*n),
# ldcmnv = as.integer(n),
# mu = double(ntrend),
# lambda = double(n),
# lambd0 = double(1),
# ierr = integer(1),
# .Package="baykrig")
#
# ans$bits<-ans$intvec[(16+npr+7*n+2*ntrend+1):(16+npr+7*n+2*ntrend+nz*n+1)]
## ans<-krige.solve(s$x,s$y,point.obj$x,point.obj$y,
## at,covmat,c0vec,c0,trend,rsearch,nsmin,nsmax,mode)
#
# retval<-list(x=ans$dblvec[1:nx],
# y=ans$dblvec[(nx+1):(nx+ny)],
# z=matrix(ans$zg,nx,ny),
# var=matrix(ans$varg,nx,ny),
# done=matrix(ans$dog, nx, ny),
# snb=matrix(ans$bits[(nz+2):(nz+n*nz+1)],nrow=n,ncol=nz,byrow=F))
# retval$z[retval$done<=0] <- NA
# retval$var[retval$done<=0] <- NA
# retval$data<-point.obj
# retval$at<-oldat
# class(retval)<-"krige.map"
# retval
#}
bk.grid <- function(point.obj,
at,
......@@ -369,7 +211,91 @@ bk.grid <- function(point.obj,
typpr[prior$type=="subjective"]<-typpr[prior$type=="subjective"]*(-1)
browser()
if(FALSE)
ans<-.C("bk_grid",
# xsw = as.double(xsw),
xsw = as.double(1),
# ysw = as.double(ysw),
ysw = as.double(1),
# xne = as.double(xne),
xne = as.double(1),
# yne = as.double(yne),
yne = as.double(1),
# angle = as.double(angle),
angle = as.double(1),
# nx = as.integer(nx),
nx = as.integer(1),
# ny = as.integer(ny),
ny = as.integer(1),
# dx = as.double(dx),
dx = as.double(1),
# dy = as.double(dy),
dy = as.double(1),
# xg = double(nx),
xg = double(1),
# yg = double(ny),
yg = double(1),
# zg = double(nz),
zg = double(1),
# varg = double(nz),
varg = double(1),
# dog = as.integer(dog),
dog = as.integer(1),
# lon = as.double(point.obj$x),
lon = as.double(1),
# lat = as.double(point.obj$y),
lat = as.double(1),
# z = as.double(point.obj[[match(at, names(point.obj))]]),
z = as.double(1),
# extrap = as.integer(extrap),
extrap = as.integer(1),
# n = as.integer(n),
n = as.integer(1),
# covtype = as.integer(covtype),
covtype = as.integer(1),
# covpar = as.double(var.mod.obj$parameters),
covpar = as.double(1),
# trend = as.integer(trend),
trend = as.integer(1),
# ntrend = as.integer(ntrend),
ntrend = as.integer(1),
# mupr = as.double(matlist.cbind(prior$mu)),
mupr = as.double(1),
# ldmpr = as.integer(ntrend),
ldmpr = as.integer(1),
# phipr = as.double(matlist.cbind(prior$phi)),
phipr = as.double(1),
# ldphpr = as.integer(ntrend),
ldphpr = as.integer(1),
# lonpr = as.double(prior$lon),
lonpr = as.double(1),
# latpr = as.double(prior$lat),
latpr = as.double(1),
# npr = as.integer(npr),
npr = as.integer(1),
# typpr = as.integer(typpr),
typpr = as.integer(1),
# rsearch = as.double(rsearch),
rsearch = as.double(1),
# nsearch = as.integer(nsearch),
nsearch = as.integer(1),
# nsmin = as.integer(nsmin),
nsmin = as.integer(1),
# nsmax = as.integer(nsmax),
nsmax = as.integer(1),
# lwork = as.integer(lwork),
lwork = as.integer(1),
# mode = as.integer(mode),
mode = as.integer(1),
# searchnb= integer(n*nz),
searchnb= integer(1),
# ierr = integer(1),
ierr = integer(1),
# glsmth = as.integer(method),
glsmth = as.integer(1)
# ,.Package= "baykrig"
)
if(TRUE) ans<-.C("bk_grid",
xsw = as.double(xsw),
ysw = as.double(ysw),
xne = as.double(xne),
......@@ -410,9 +336,8 @@ browser()
searchnb= integer(n*nz),
ierr = integer(1),
glsmth = as.integer(method),
.Package= "baykrig")
ans$bits<-ans$intvec[(16+npr+7*n+2*ntrend+1):(16+npr+7*n+2*ntrend+nz*n+1)]
# ,.Package= "baykrig"
)
browser()
retval<-list(x=ans$xg,
y=ans$yg,
......
This diff is collapsed.
......@@ -54,4 +54,4 @@ leman.prior.0<-empirical.prior(leman.78,cadpbm~1,leman.88.vmsph,prior=leman.prio
# crash:
#leman.bk.0 <- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior.0,var.mod.obj = leman.88.vmsph, xsw=min(leman.bank$x),ysw=min(leman.bank$y), xne=max(leman.bank$x), yne=max(leman.bank$y), nx=50, ny=50, trend=0, rsearch = 10, extrap = T,border=leman.bank, duplicate="mean")
leman.bk.0 <- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior.0,var.mod.obj = leman.88.vmsph, xsw=min(leman.bank$x),ysw=min(leman.bank$y), xne=max(leman.bank$x), yne=max(leman.bank$y), nx=50, ny=50, trend=0, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment