Skip to content

GitLab

B
baykrig
Commit e4510cc1 authored by agebhard's avatar agebhard
Browse files
Options

return of lambda ... optional (get.lm). crashes if get.lm==T.

parent a897e6ab
Hide whitespace changes
Inline Side-by-side
Showing with 75 additions and 42 deletions
R/bk.grid.R
View file @ e4510cc1
......@@ -18,7 +18,8 @@ bk.grid <- function(point.obj,
mode=3,
duplicate = "error",
dupfun = NULL,
method="gqr")
method="gqr",
get.lm=FALSE)
{
tmp <- check.gridparams(angle,xsw,xne,ysw,yne,
dx,dy,nx,ny)
......@@ -78,6 +79,15 @@ bk.grid <- function(point.obj,
snbbit<-rep(0,1+n*nz)
snbbit[1]<-1
if(get.lm){
mu <- double(ntrend*nz)
lambda <- double(n*nz)
lambd0 <- double(nz)
} else {
mu <- double(ntrend)
lambda <- double(n)
lambd0 <- double(1)
}
ans<-.C("bk_grid",
......@@ -121,10 +131,12 @@ bk.grid <- function(point.obj,
nsmax = as.integer(nsmax),
lwork = as.integer(lwork),
mode = as.integer(mode),
lambda = double(n*nz),
lambd0 = double(nz),
mu = as.double(mu),
lambda = as.double(lambda),
lambd0 = double(lambd0),
bits = as.integer(c(integer(nz),snbbit)),
ierr = integer(1),
get.lm = as.integer(get.lm),
glsmth = as.integer(method),
# ,.Package= "baykrig"
)
......@@ -134,10 +146,13 @@ bk.grid <- function(point.obj,
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),
lambda=matrix(ans$lambda,nrow=n,ncol=nz,byrow=FALSE),
lambda0=matrix(ans$lambd0,nx,ny)
snb=matrix(ans$bits[(nz+2):(nz+n*nz+1)],nrow=n,ncol=nz,byrow=F)
)
if(get.lm){
retval$lambda <- matrix(ans$lambda,nrow=n,ncol=nz,byrow=FALSE)
retval$lambda0 <- matrix(ans$lambd0,nx,ny)
retval$mu <- matrix(ans$mu,nrow=n,ncol=ntrend,byrow=FALSE)
}
retval$z[retval$done<=0] <- NA
retval$var[retval$done<=0] <- NA
retval$lambda0[retval$done<=0] <- NA
......
devel/fresh/.Rhistory
View file @ e4510cc1
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=100, ny=100, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean",method="ols")
ls()
library(baykrig)
library(baykrig)
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=5, ny=5, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
library(baykrig)
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=5, ny=5, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=150, ny=50, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
library(baykrig)
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=10, ny=10, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
plot(leman.bk)
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=100, ny=100, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
plot(leman.bk)
leman.bk.2<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=200, ny=200, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
library(baykrig)
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=10, ny=10, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
plot(leman.bk)
leman.bk.pt <- bk.points(point = leman.88.pt , at = "cadpbm", prior=leman.prior, var.mod.obj = leman.88.vmsph, x=c(530,550),y=c(142,147), trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
library(baykrig)
leman.bk<- bk.grid(point = leman.88.pt , at = "cadpbm", prior=leman.prior,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=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
plot(leman.bk)
plot(leman.bk,show.snb=T)
plot(leman.bk,show.snb=T,bias=T)
dev.print(file="bias.ps")
leman.bk.pt <- bk.points(point = leman.88.pt , at = "cadpbm", prior=leman.prior.1, var.mod.obj = leman.88.vmsph, x=c(530,550),y=c(142,147), trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
example(prior)
example(emp.prior)
ls("package:baykrig")
example(empirical.prior)
leman.bk.pt <- bk.points(point = leman.88.pt , at = "cadpbm", prior=leman.prior.1, var.mod.obj = leman.88.vmsph, x=c(530),y=c(142), trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
leman.bk.pt
str(leman.bk.pt)
q()
library(baykrig)
plot(leman.bk,show.snb=T,bias=T)
ls()
example(bk.grid)
library(baykrig)
leman.bk.pt <- bk.points(point = leman.88.pt , at = "cadpbm", prior=leman.prior, var.mod.obj = leman.88.vmsph, x=c(530,550),y=c(142,147), trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
ls()
example(empirical.prior)
save.image()
help(bk.grid)
library(baykrig)
leman.bk.pt <- bk.points(point = leman.88.pt , at = "cadpbm", prior=leman.prior, var.mod.obj = leman.88.vmsph, x=c(530,550),y=c(142,147), trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean")
library(baykrig)
leman.bk1 <- bk.grid(point = leman.88.pt, at = "cadpbm", prior=leman.prior.1,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=100, ny=100, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean",get.lm=T)
library(baykrig)
leman.bk1 <- bk.grid(point = leman.88.pt, at = "cadpbm", prior=leman.prior.1,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=100, ny=100, trend=1, rsearch = 10, extrap = F,border=leman.bank, duplicate="mean",get.lm=F)
str(leman.bk1)
str(leman.bk1$var)
(leman.bk1$var)
q()
src/bk_grid.c
View file @ e4510cc1
#include "bk_grid.h"
void F77_NAME(bk_grid)(double *xsw,
void bk_grid__(double *xsw,
double *ysw,
double *xne,
double *yne,
......@@ -40,10 +40,12 @@ void F77_NAME(bk_grid)(double *xsw,
int *nsmax,
int *lwork,
int *mode,
double *mu,
double *lambda,
double *lambd0,
int *searchnb,
int *ierr,
int *retlm,
int *glsmth){
/* simple Fortran wrapper */
bk_grid(xsw,
......@@ -86,10 +88,12 @@ bk_grid(xsw,
nsmax,
lwork,
mode,
mu,
lambda,
lambd0,
searchnb,
ierr,
retlm,
glsmth);
}
......@@ -133,10 +137,12 @@ void bk_grid(double *xsw,
int *nsmax,
int *lwork,
int *mode,
double *mu,
double *lambda,
double *lambd0,
int *searchnb,
int *ierr,
int *retlm,
int *glsmth){
int nz=(*nx)*(*ny), ldc0=(*n),ldphwk=(*ntrend),
......@@ -148,7 +154,6 @@ void bk_grid(double *xsw,
*fwork, *fwrk2, *f0work, *dist, *kwork,
*rhswork, *fpwork, *fpfwork, *fpf0wrk, *chlup,
*cminv, *work, *ferr, *berr,
*mu,
cov0;
int *indsnb, *indsnw, *indsrt, *ipiv, *ipvt, *iwork;
......@@ -183,7 +188,6 @@ void bk_grid(double *xsw,
ferr =Calloc((size_t)(*n),double);
berr =Calloc((size_t)(*n),double);
iwork =Calloc((size_t)(3*(*n)),int);
mu =Calloc((size_t)(*ntrend),double);
#else
c0vec =(double *) R_alloc((*n),sizeof(double));
muwrk =(double *) R_alloc((*ntrend),sizeof(double));
......@@ -213,7 +217,6 @@ void bk_grid(double *xsw,
ferr =(double *) R_alloc((*n),sizeof(double));
berr =(double *) R_alloc((*n),sizeof(double));
iwork =(int *) R_alloc(3*(*n),sizeof(int));
mu =(double *) R_alloc((*ntrend),sizeof(double));
#endif
F77_CALL(bkgrid)(xsw,
......@@ -301,10 +304,10 @@ void bk_grid(double *xsw,
lambd0,
searchnb,
ierr,
retlm,
glsmth);
#ifndef TRANSIENT
Free(mu);
Free(iwork);
Free(berr);
Free(ferr);
......@@ -338,7 +341,6 @@ void bk_grid(double *xsw,
#else
/*
free(mu);
free(iwork);
free(berr);
free(ferr);
......
src/bk_grid.h
View file @ e4510cc1
......@@ -43,13 +43,15 @@ void bk_grid(double *xsw,
int *nsmax,
int *lwork,
int *mode,
double *mu,
double *lambda,
double *lambd0,
int *searchnb,
int *ierr,
int *retlm,
int *glsmth);
void F77_NAME(bk_grid)(double *xsw,
void bk_grid__(double *xsw,
double *ysw,
double *xne,
double *yne,
......@@ -89,10 +91,12 @@ void F77_NAME(bk_grid)(double *xsw,
int *nsmax,
int *lwork,
int *mode,
double *mu,
double *lambda,
double *lambd0,
int *searchnb,
int *ierr,
int *retlm,
int *glsmth);
void F77_NAME(bkgrid)(double *xsw,
......@@ -180,6 +184,7 @@ void F77_NAME(bkgrid)(double *xsw,
double *lambd0,
int *searchnb,
int *ierr,
int *retlm,
int *glsmth);
src/bkgrid.f
View file @ e4510cc1
......@@ -83,9 +83,10 @@
. LAMBD0,
. BITS,
. IERR,
. RETLM,
. GLSMTH)
IMPLICIT NONE
INTEGER NX,NY,NZ,N,COVTYPE,TREND,NTREND,LDZG,
INTEGER NX,NY,NZ,N,COVTYPE,TREND,NTREND,LDZG,RETLM,
. NSEARCH,NSMIN,NSMAX,MODE,IERR,INDSNB(*),INDSNW(*),
. INDSRT(*),IPIV(*),IPT,EXTRAP,DOG(NX,*),LDKWRK,EXTCOV,
. LDCOV,LDFWRK,LDMPR,LDPHPR,LDPHWK,LDCVBT,LWORK,LDLMBD,
......@@ -94,7 +95,7 @@
. XG(*),YG(*),ZG(LDZG,*),VARG(LDZG,*),
. LON(*),LAT(*),Z(*),COVMAT(LDCOV,*),C0VEC(*),COV0,
. RSEARCH,FWORK(LDFWRK,*),F0WORK(*),
. KWORK(LDKWRK,*),RHSWORK(*),MU(*),
. KWORK(LDKWRK,*),RHSWORK(*),MU(NTREND,*),
. LAMBDA(LDLMBD,*),FWRK2(LDFWRK,*),
. COVPAR(*),
. FPWORK(LDFWRK,*),FPFWORK(LDFWRK,*),
......@@ -255,10 +256,16 @@ c loop over all points and pass them to KRIGE:
if (bits(1+nz).ne.0) then
usesbbt=1
end if
PCNT=0
if (retlm.eq.1) then
PCNT=0
else
PCNT=1
end if
DO 20 I=1,NX
DO 10 J=1,NY
PCNT=PCNT+1
if (retlm.eq.1) then
PCNT=PCNT+1
end if
BITS(I+NY*(J-1)) = PCNT
X0=XG(I)
Y0=YG(J)
......@@ -335,7 +342,7 @@ c the main work is now done by BK:
. IPIV,
. IWORK,
. MODE,
. MU,
. MU(1,pcnt),
. NTREND,
. Z0,
. NA0,
......@@ -359,12 +366,16 @@ c extract results for this tile
DOG(I,J)=-1
ZG(I,J)=0
VARG(I,J)=0
LAMBD0(I,J)=0
if (retlm.eq.1) then
LAMBD0(I,J)=0
end if
c write(*,*)"x"
ELSE
ZG(I,J)=Z0
VARG(I,J)=VAR0
LAMBD0(I,J)=L0
if (retlm.eq.1) then
LAMBD0(I,J)=L0
end if
c write(*,*)"o"
c VARG(I,J)=IWORK(1)*1.0D0
c VARG(I,J)=lambd0
......
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