diff --git a/.Rbuildignore b/.Rbuildignore index f76625a8ee2fd862c50c371afe5b9cd914dd57dd..671ff14d046fb9292426ed9555318d96fda7d122 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -2,6 +2,7 @@ orig config.log config.status autom4te.cache +src-old src-c src-i386 build-debug.sh diff --git a/LICENSE b/LICENSE index 2feaa5b8c48f771cc659865c390a2fe5ef4a5baf..9327ff2ba01abb6fd4f6c2f233897c84e9af6856 100644 --- a/LICENSE +++ b/LICENSE @@ -3,13 +3,14 @@ http://www.acm.org/publications/policies/software-copyright-notice In detail: -1. Fortran code (src/*.f): +1. Fortran code (src/*.f except src/bilinear.f): Copyrighted and Licensed by ACM, see http://www.acm.org/publications/policies/software-copyright-notice -2. R interface (src/init.c src/akima.h R/*.R man/*.Rd data/*): +2. R interface (src/init.c src/akima.h R/*.R man/*.Rd data/* + except */bilinear.*) The R interface code has been developed as work based on the ACM licensed code, hence it is also ACM licensed, copyright @@ -21,6 +22,7 @@ and to fulfill this, the modified work including the R interface is available free to secondary users, and no charge is associated with such copies. - +3. Bilinear interpolation (*/bilinear*): Copyright A. Gebhardt, + free to reuse whithout restrictions. diff --git a/R/bilinear.R b/R/bilinear.R index 1b44870c600ccb2240527079e59406f618564841..8cfdb9ff245b318d9611156c59c35c83ed18f4d4 100755 --- a/R/bilinear.R +++ b/R/bilinear.R @@ -19,9 +19,12 @@ bilinear <- function(x,y,z,x0,y0){ as.double(z), as.integer(nx), as.integer(ny), + ier=integer(1), PACKAGE="akima") - - list(x=x0,y=y0,z=ret$z0) + if(ret$ier==1) + stop("duplicate coordinates in input grid!") + else + list(x=x0,y=y0,z=ret$z0) } diff --git a/R/interp.R b/R/interp.R index 2c61f0cd671e688be998e558c325d5ca2cb3a44b..880cfadbabef4dfe3bee725b289e3f2143c27df9 100644 --- a/R/interp.R +++ b/R/interp.R @@ -4,7 +4,8 @@ interp <- yo = seq(min(y), max(y), length = ny), linear = TRUE, extrap = FALSE, duplicate = "error", dupfun = NULL, nx=40, ny=40, - jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE) + jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE, + remove = !linear) { ## handle sp data, save coordinate and value names is.sp <- FALSE @@ -25,12 +26,6 @@ interp <- } else stop("either x,y,z are numerical or x is SpatialPointsDataFrame and z a name of a data column in x") } - ## FIXME: drop old akima code - if(linear) - ret <- interp.old(x,y,z,xo,yo,ncp=0,extrap=FALSE, - duplicate=duplicate,dupfun=dupfun) - else { - if(!(all(is.finite(x)) && all(is.finite(y)) && all(is.finite(z)))) stop("missing values and Infs not allowed") @@ -77,6 +72,12 @@ interp <- ## storage.mode(zo) <- "double" miss <- !extrap # if not extrapolating, set missing values + ## Defaults from Fortran code for triangle removal moved to R code, + ## see SDTRTT: + hbrmn <- 0.1 # height to base ratio for thin triangles + nrrtt <- 5 # recursion depth for triangle removal, 0 disables + if(!remove) nrrtt <- 0 + ans <- .Fortran("sdsf3p", md = as.integer(1), ndp = as.integer(n), @@ -89,17 +90,21 @@ interp <- y = as.double(yo), z = as.double(matrix(0,nx,ny)), ier = integer(1), - wk = double(36 * n), - iwk = integer(25 * n), + wk = double(36 * 5* n), + iwk = integer(39 * n), extrap = as.logical(matrix(extrap,nx,ny)), - near = integer(n), - nxt = integer(n), - dist = double(n), linear = as.logical(linear), + hbrmn = as.double(hbrmn), + nrrtt = as.integer(nrrtt), PACKAGE = "akima") if(miss) ans$z[ans$extrap] <- NA + ## Error code 11 from sdsf3p indicates failure of thin triangle removal. + if(ans$ier==11){ + stop("removal of thin triangles from border failed. try to re-run with remove=FALSE") + } + ## Error code 10 from sdsf3p indicates error code -2 from trmesh: ## first three points collinear. ## Try to add jitter to data locations to avoid collinearities, @@ -150,13 +155,12 @@ interp <- y = as.double(yo), z = as.double(matrix(0,nx,ny)), ier = integer(1), - double(36 * n), - integer(25 * n), + double(36 * 5* n), + integer(39 * n), extrap = as.logical(matrix(extrap,nx,ny)), - near = integer(n), - nxt = integer(n), - dist = double(n), linear = as.logical(linear), + hbrmn = as.double(hbrmn), + nrrtt = as.integer(nrrtt), PACKAGE = "akima") if(miss) ans$z[ans$extrap] <- NA @@ -170,8 +174,8 @@ interp <- } ## prepare return value if(is.sp){ - zm <- dim(ans$z)[1] - zn <- dim(ans$z)[2] + zm <- nx + zn <- ny zvec <- c(ans$z) xvec <- c(matrix(rep(ans$x,zn),nrow=zm,ncol=zn,byrow=FALSE)) yvec <- c(matrix(rep(ans$y,zm),nrow=zm,ncol=zn,byrow=TRUE)) @@ -184,6 +188,5 @@ interp <- } else { ret <- list(x=ans$x,y=ans$y,z=matrix(ans$z,nx,ny)) } - } ## END FIXME ret } diff --git a/R/interp.old.R b/R/interp.old.R index a4fd34ad526a3bb86f3f5184e1de2849c79e9937..fea4d5cace99ef2834ed2009ee051272abccc148 100644 --- a/R/interp.old.R +++ b/R/interp.old.R @@ -2,76 +2,9 @@ yo = seq(min(y), max(y), length = 40), ncp = 0, extrap = FALSE, duplicate = "error", dupfun = NULL) { - - ## warning("interp.old() is deprecated, future versions will only provide interp()") - if(!(all(is.finite(x)) && all(is.finite(y)) && all(is.finite(z)))) - stop("missing values and Infs not allowed") - if(ncp > 25) { - ncp <- 25 - cat("ncp too large, using ncp=25\n") - } - - drx <- diff(range(x)) - dry <- diff(range(y)) - if(drx == 0 || dry == 0) - stop("all data collinear") # other cases caught in Fortran code - if(drx/dry > 10000 || drx/dry < 0.0001) - stop("scales of x and y are too dissimilar") - n <- length(x) - nx <- length(xo) - ny <- length(yo) - if(length(y) != n || length(z) != n) - stop("Lengths of x, y, and z do not match") - - xy <- paste(x, y, sep = ",")# trick for 'duplicated' (x,y)-pairs - if(duplicate == "error") { - if(any(duplicated(xy))) - stop("duplicate data points: need to set 'duplicate = ..' ") - } - else { ## duplicate != "error" - - i <- match(xy, xy) - if(duplicate == "user") - dupfun <- match.fun(dupfun)#> error if it fails - - ord <- !duplicated(xy) - if(duplicate != "strip") { - centre <- function(x) - switch(duplicate, - mean = mean(x), - median = median(x), - user = dupfun(x)) - z <- unlist(lapply(split(z,i), centre)) - } else { - z <- z[ord] - } - x <- x[ord] - y <- y[ord] - n <- length(x) - } - - zo <- matrix(0, nx, ny) - storage.mode(zo) <- "double" - miss <- !extrap #if not extrapolating use missing values - misso <- matrix(miss, nx, ny) - if(extrap & ncp == 0) - warning("Cannot extrapolate with linear option") - ans <- .Fortran("idsfft", - as.integer(1), - as.integer(ncp), - as.integer(n), - as.double(x), - as.double(y), - as.double(z), - as.integer(nx), - as.integer(ny), - x = as.double(xo), - y = as.double(yo), - z = zo, - integer((31 + ncp) * n + nx * ny), - double(5 * n), - misso = as.logical(misso), - PACKAGE = "akima")[c("x", "y", "z", "misso")] - ans$z[ans$misso] <- NA - ans[c("x", "y", "z")] + warning("interp.old() is deprecated, use interp()") + interp(x, y, z, + xo, + yo, linear=(ncp==0), + extrap, duplicate, dupfun) } diff --git a/R/interpp.R b/R/interpp.R index 819fc43b64bed0ece90f4cdd36d56c38ecb367d4..95f302f035fef267827d952703b57808ad553792 100644 --- a/R/interpp.R +++ b/R/interpp.R @@ -1,6 +1,7 @@ "interpp"<-function(x, y=NULL, z, xo, yo=NULL, linear = TRUE, extrap = FALSE, duplicate = "error", dupfun = NULL, - jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE) + jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE, + remove = !linear) { ## handle sp data, save coordinate and value names @@ -29,12 +30,6 @@ "or both x and xo have to be SpatialPointsDataFrames", "and z a name of a data column in x")) } - ## FIXME: drop old akima code - if(linear) - ret <- interpp.old(x,y,z,xo,yo,ncp=0,extrap=FALSE, - duplicate=duplicate,dupfun=dupfun) - else { - if(!(all(is.finite(x)) && all(is.finite(y)) && all(is.finite(z)))) stop("missing values and Infs not allowed") if(is.null(xo)) @@ -91,6 +86,11 @@ zo <- rep(0, np) miss <- !extrap #if not extrapolating use missing values extrap <- rep(extrap, np) + ## Defaults from Fortran code for triangle removal moved to R code, + ## see SDTRTT: + hbrmn <- 0.1 # height to base ratio for thin triangles + nrrtt <- 5 # recursion depth for triangle removal, 0 disables + if(!remove) nrrtt <- 0 ans <- .Fortran("sdbi3p", md = as.integer(1), @@ -103,23 +103,29 @@ y = as.double(yo), z = as.double(zo), ier = integer(1), - wk = double(17 * n), - iwk = integer(25 * n), + wk = double(17 * 5 * n), + iwk = integer(39 * n), extrap = as.logical(extrap), - near = integer(n), - nxt = integer(n), - dist = double(n), linear = as.logical(linear), + hbrmn = as.double(hbrmn), + nrrtt = as.integer(nrrtt), PACKAGE = "akima") if(miss) ans$z[ans$extrap]<-NA - ## Error code 10 from sdsf3p indicates error code -2 from trmesh: + + ## Error code 11 from sdbi3p indicates failure of thin triangle removal. + if(ans$ier==11){ + stop("removal of thin triangles from border failed. try to re-run with remove=FALSE") + } + + + ## Error code 10 from sdbi3p indicates error code -2 from trmesh: ## first three points collinear. ## Try to add jitter to data locations to avoid collinearities, ## start with diff(range(x))*jitter*jitter.trials^1.5 and repeat for ## jitter.trials steps until success (ier=0) - if(ans$ier==10) + if(ans$ier==10){ warning("collinear points, trying to add some jitter to avoid collinearities!") jitter.trials <- 1 success <- FALSE @@ -143,13 +149,12 @@ y = as.double(yo), z = as.double(zo), ier = integer(1), - wk = double(17 * n), - iwk = integer(25 * n), + wk = double(17 * 5 * n), + iwk = integer(39 * n), extrap = as.logical(extrap), - near = integer(n), - nxt = integer(n), - dist = double(n), linear = as.logical(linear), + hbrmn = as.double(hbrmn), + nrrtt = as.integer(nrrtt), PACKAGE = "akima") if(miss) ans$z[ans$extrap] <- NA @@ -160,6 +165,7 @@ if(success) warning("success: collinearities reduced through jitter") jitter.trials <- jitter.trials+1 + } } if(is.sp){ nona <- !is.na(ans$z) @@ -170,6 +176,5 @@ } else { ret <- list(x=ans$x,y=ans$y,z=ans$z) } - } ## END FIXME ret } diff --git a/R/interpp.new.R b/R/interpp.new.R index 8593d266f248c92165128d4392253ad6c029394c..4823a058db7d09a3c7706821c0e5bb40bdf80284 100644 --- a/R/interpp.new.R +++ b/R/interpp.new.R @@ -1,7 +1,7 @@ "interpp.new"<-function(x, y, z, xo, yo, extrap = FALSE, duplicate = "error", dupfun = NULL) { - warning("interp.new() is deprecated, use interp()") + warning("interpp.new() is deprecated, use interpp()") interpp(x, y, z, xo, yo, linear=FALSE, diff --git a/R/interpp.old.R b/R/interpp.old.R index f5b1e4cdd4c6aa58b38c5bc35d8f61b30957b0d5..57c910fec4e60fd326e94b1f5dcfa21d2bc75cdc 100644 --- a/R/interpp.old.R +++ b/R/interpp.old.R @@ -1,82 +1,9 @@ "interpp.old"<-function(x, y, z, xo, yo, ncp = 0, extrap = FALSE, duplicate = "error", dupfun = NULL) { - warning("interpp.old() is deprecated, future versions will only provide interpp()") - if(!(all(is.finite(x)) && all(is.finite(y)) && all(is.finite(z)))) - stop("missing values and Infs not allowed") - if(is.null(xo)) - stop("xo missing") - if(is.null(yo)) - stop("yo missing") - if(ncp>25){ - ncp <- 25 - cat("ncp too large, using ncp=25\n") - } - drx <- diff(range(x)) - dry <- diff(range(y)) - if(drx == 0 || dry == 0) - stop("all data collinear") # other cases caught in Fortran code - if(drx/dry > 10000 || drx/dry < 0.0001) - stop("scales of x and y are too dissimilar") - n <- length(x) - np <- length(xo) - if(length(yo)!=np) - stop("length of xo and yo differ") - if(length(y) != n || length(z) != n) - stop("Lengths of x, y, and z do not match") - xy <- paste(x, y, sep =",") - i <- match(xy, xy) - if(duplicate=="user" && !is.function(dupfun)) - stop("duplicate=\"user\" requires dupfun to be set to a function") - if(duplicate!="error") - { - centre <- function(x) { - switch(duplicate, - mean = mean(x), - median = median(x), - user = dupfun(x) - ) - } - if(duplicate!="strip"){ - z <- unlist(lapply(split(z,i), centre)) - ord <- !duplicated(xy) - x <- x[ord] - y <- y[ord] - n <- length(x) - } - else{ - ord <- (hist(i,plot=FALSE,freq=TRUE,breaks=seq(0.5,max(i)+0.5,1))$counts==1) - x <- x[ord] - y <- y[ord] - z <- z[ord] - n <- length(x) - } - } - else - if(any(duplicated(xy))) - stop("duplicate data points") - zo <- rep(0, np) - storage.mode(zo) <- "double" - miss <- !extrap #if not extrapolating use missing values - misso <- seq(miss, np) - if(extrap & ncp == 0) - warning("Cannot extrapolate with linear option") - ans <- .Fortran("idbvip", - as.integer(1), - as.integer(ncp), - as.integer(n), - as.double(x), - as.double(y), - as.double(z), - as.integer(np), - x = as.double(xo), - y = as.double(yo), - z = zo, - integer((31 + ncp) * n + np), - double(8 * n), - misso = as.logical(misso), - PACKAGE = "akima") - temp <- ans[c("x", "y", "z", "misso")] - temp$z[temp$misso]<-NA - temp[c("x", "y", "z")] + warning("interpp.old() is deprecated, use interpp()") + interpp(x, y, z, + xo, + yo, linear=(ncp==0), + extrap=extrap, duplicate=duplicate, dupfun=dupfun) } diff --git a/man/interp.Rd b/man/interp.Rd index f94851130631ba1b248f62fc37f408142717bdb3..c5dbb233d603b8827e7f80877425ef64c3934827 100644 --- a/man/interp.Rd +++ b/man/interp.Rd @@ -12,7 +12,8 @@ interp(x, y=NULL, z, xo=seq(min(x), max(x), length = nx), yo=seq(min(y), max(y), length = ny), linear = TRUE, extrap=FALSE, duplicate = "error", dupfun = NULL, nx = 40, ny = 40, - jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE) + jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE, + remove = !linear) } \arguments{ \item{x}{ @@ -96,6 +97,12 @@ interp(x, y=NULL, z, xo=seq(min(x), max(x), length = nx), \item{jitter.random}{logical, see \code{jitter}, defaults to \code{FALSE} } + \item{remove}{logical, indicates whether Akimas removal of thin triangles along + the border of the convex hull should be performed, experimental setting! + defaults to \code{!linear}, so it will be left out for linear interpolation + by default. For some point configurations it is the only + available option to skip this removal step. + } } \value{ list with 3 components: @@ -113,12 +120,14 @@ interp(x, y=NULL, z, xo=seq(min(x), max(x), length = nx), \code{SpatialPixelssDataFrame} is returned. } \note{ - \code{interp} uses Akimas new Fortran code from 1996 - for spline interpolation, the triangulation (based on Renkas tripack) - is reused for linear interpolation. In this newer version Akima - switched from his own triangulation to Renkas tripack (=TOMS 751). + \code{interp} uses Akimas new Fortran code (AMS 761) from 1996 in the revised + version by Renka from 1998 for spline interpolation, the triangulation + (based on Renkas tripack) is reused for linear interpolation. In this + newer version Akima switched from his own triangulation to Renkas + tripack (AMS 751). - Note that S-Plus uses (used?) the old Fortran code from Akima 1978. + Note that earlier versions (up to version 0.5-12) as well as S-Plus + used the old Fortran code from Akima 1978 (AMS 526). The resulting structure is suitable for input to the functions \code{\link{contour}} and \code{\link{image}}. Check @@ -157,6 +166,10 @@ interp(x, y=NULL, z, xo=seq(min(x), max(x), length = nx), two-dimensional Delaunay triangulation package. ACM Transactions on Mathematical Software. \bold{22}, 1-8. + + R. J. Renka and Ron Brown (1998). Remark on algorithm 761. + ACM Transactions on Mathematical Software. + \bold{24}, 383-385. } \seealso{ \code{\link{contour}}, \code{\link{image}}, diff --git a/man/interpp.Rd b/man/interpp.Rd index c3ea5e89944688e685f8c907740a0638d06ba1f6..fa36f4a42a2d93202e6edfdadf03d893a45fa1f8 100644 --- a/man/interpp.Rd +++ b/man/interpp.Rd @@ -6,7 +6,8 @@ \usage{ interpp(x, y=NULL, z, xo, yo=NULL, linear=TRUE, extrap=FALSE, duplicate = "error", dupfun = NULL, - jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE) + jitter = 10^-12, jitter.iter = 6, jitter.random = FALSE, + remove = !linear) } \arguments{ \item{x}{ @@ -80,6 +81,12 @@ interpp(x, y=NULL, z, xo, yo=NULL, linear=TRUE, extrap=FALSE, \item{jitter.random}{logical, see \code{jitter}, defaults to \code{FALSE} } + \item{remove}{logical, indicates whether Akimas removal of thin triangles along + the border of the convex hull should be performed, experimental setting! + defaults to \code{!linear}, so it will be left out for linear interpolation + by default. For some point configurations it is the only + available option to skip this removal step. + } } \value{ list with 3 components: @@ -145,6 +152,10 @@ interpp(x, y=NULL, z, xo, yo=NULL, linear=TRUE, extrap=FALSE, two-dimensional Delaunay triangulation package. ACM Transactions on Mathematical Software. \bold{22}, 1-8. + + R. J. Renka and Ron Brown (1998). Remark on algorithm 761. + ACM Transactions on Mathematical Software. + \bold{24}, 383-385. } \seealso{ \code{\link[graphics]{contour}}, \code{\link[graphics]{image}}, @@ -157,7 +168,7 @@ data(akima) # linear interpolation at points (1,2), (5,6) and (10,12) akima.lip<-interpp(akima$x, akima$y, akima$z,c(1,5,10),c(2,6,12)) akima.lip$z -# spline interpolation +# spline interpolation at the same locations akima.sip<-interpp(akima$x, akima$y, akima$z,c(1,5,10),c(2,6,12), linear=FALSE) akima.sip$z @@ -171,7 +182,7 @@ akima.sip$z ## interpolate on this 30 points: ## note: both "meuse" and "m0" are sp objects ## (SpatialPointsDataFrame) !! - ## arguments z and xo have to named, y has to be omitted! + ## arguments z and xo have to given, y has to be omitted! ipp <- interpp(meuse,z="zinc",xo=m0) spplot(ipp) } diff --git a/src/akima.h b/src/akima.h index 46b1f82ea59f73a967ff8af122d2654f159969cb..684a4ebf4380df7c3567deed26ce2dffd017af64 100644 --- a/src/akima.h +++ b/src/akima.h @@ -1,7 +1,7 @@ #include -/* ACM 526, soon to be removed: */ +/* ACM 526, removed in version 0.6-3: int F77_NAME(idbvip) (int *md, int *ncp, int *ndp, double *xd, double *yd, double *zd, int *nip, double *xi, double *yi, double *zi, @@ -12,6 +12,7 @@ int F77_NAME(idsfft) (int *md, int *ncp, int *ndp, int *nxi, int *nyi, double *xi, double *yi, double *zi, int *iwk, double *wk, int *missi); +*/ /* ACM 679: */ int F77_NAME(uvip3p) (int *np, int *nd, double *xd, double *yd, @@ -29,13 +30,13 @@ int F77_NAME(rgbi3p) (int *md, int *nxd, int *nyd, double *xd, double *yd, doubl int F77_NAME(sdsf3p) (int *md, int *ndp, double *xd, double *yd, double *zd, int *nxi, double *xi, int *nyi, double *yi, double *zi, int *ier, double *wk, int *iwk, - int *extrpi, int *near, int *next, double *dist); + int *extrpi, int *linear, double *hbrmn, int *nrrtt); int F77_NAME(sdbi3p) (int *md, int *ndp, double *xd, double *yd, double *zd, int *nip, double *xi, double *yi, double *zi, int *ier, double *wk, int *iwk, - int *extrpi, int *near, int *next, double *dist); + int *extrpi, int *linear, double *hbrmn, int *nrrtt); /* bilinear, A. Gebhardt: */ int F77_NAME(biliip) (double *x0, double *y0, double *z0, double *x, double *y, double *z, - int *nx, int *ny); + int *nx, int *ny, int *ier); diff --git a/src/akima761.f b/src/akima761.f index 7fc6590f818fd0f5f353213a22f2c9287781a185..d3af0268ea6e40fef5a9130a924b7bddc8267c65 100644 --- a/src/akima761.f +++ b/src/akima761.f @@ -1,5 +1,5 @@ - SUBROUTINE SDBI3P(MD,NDP,XD,YD,ZD,NIP,XI,YI, ZI,IER, WK,IWK, - + EXTRPI,NEAR,NEXT,DIST,LINEAR) + SUBROUTINE SDBI3P(MD,NDP,XD,YD,ZD,NIP,XI,YI,ZI,IER,WK,IWK, + + EXTRPI,LINEAR,HBRMN,NRRTT) * * Scattered-data bivariate interpolation * (a master subroutine of the SDBI3P/SDSF3P subroutine package) @@ -40,18 +40,24 @@ * = 1 for NDP = 9 or less * = 2 for NDP not equal to NDPPV * = 3 for NIP = 0 or less -* = 9 for errors in SDTRAN called by this subroutine, except the next one +* = 9 for errors in SDTRAN called by this subroutine. +* agebhard: * =10 for error 2 in SDTRAN (first three points collinear), as this can * be fixed by adding jitter to the locations in the calling routine. * * The other arguments are * WK = two-dimensional array of dimension NDP*17 used * internally as a work area, -* IWK = two-dimensional integer array of dimension NDP*25 +* IWK = two-dimensional integer array of dimension NDP*39 * used internally as a work area. +* agebhard: additional arguments: +* LINEAR = switches between splines (Akima) and linear interpolation +* EXTRPI = indicates whether point was extrapolated or not * -* agebhard@uni-klu.ac.at: added from new TRIPACK: -* NEAR, NEXT, DIST work arrays from TRMESH, size NDP +* HBRMN and NRRTT = (experimental!) params of SDTRTT changed to arguments +* use NRRTT=0 to completely switch off Akimas "remove +* triangles from boundary step", should be default for +* linear interpolation. * * The very first call to this subroutine and the call with a new * NDP value or new XD and YD arrays must be made with MD=1. The @@ -63,11 +69,6 @@ * the call with MD=3 and its preceding call, the WK and IWK * arrays must not be disturbed. * -* The user of this subroutine can save the storage, by NDP*6 -* numerical storage units, by placing the statement -* EQUIVALENCE (WK(1,1),IWK(1,20)) -* in the program that calls this subroutine. -* * The constant in the PARAMETER statement below is * NIPIMX = maximum number of output points to be processed * at a time. @@ -76,6 +77,15 @@ * This subroutine calls the SDTRAN, SDPD3P, SDLCTN, and SDPLNL * subroutines. * +* Comments added to Remark: +* +* It also calls TRMESH from the TRIPACK package of ACM Algorithm +* 751 by R. J. Renka. The TRMESH subroutine in turn calls either +* directly or indirectly 12 other subprograms included in the +* package. In addition, a newly added routine, GRADC, is called +* to compute partial derivatives at those nodes for which the +* cubic fit failed due to ill-conditioning. +* * * Specification statements * .. Parameters .. @@ -83,24 +93,26 @@ PARAMETER (NIPIMX=51) * .. * .. Scalar Arguments .. - INTEGER IER,MD,NDP,NIP,NEAR(NDP),NEXT(NDP) + DOUBLE PRECISION HBRMN + INTEGER IER,MD,NDP,NIP,NRRTT LOGICAL LINEAR - * .. * .. Array Arguments .. - DOUBLE PRECISION WK(NDP,17),XD(NDP),XI(NIP),YD(NDP), - + YI(NIP),ZD(NDP),ZI(NIP),DIST(NDP) - INTEGER IWK(NDP,25) +* agebhard: increase linenumber of WK by factor 5 + DOUBLE PRECISION WK(NDP*5,17),XD(NDP),XI(NIP),YD(NDP), + + YI(NIP),ZD(NDP),ZI(NIP) + INTEGER IWK(NDP,39) LOGICAL EXTRPI(NIP) * .. * .. Local Scalars .. - INTEGER IERT,IIP,NDPPV,NIPI,NL,NT + DOUBLE PRECISION PDX,PDXX,PDXY,PDY,PDYY + INTEGER I,IERT,IIP,J,K,L,LNEW,NDPPV,NIPI,NL,NT * .. * .. Local Arrays .. - INTEGER ITLI(NIPIMX),KTLI(NIPIMX) + INTEGER ITLI(NIPIMX),KTLI(NIPIMX),LCC(1) * .. * .. External Subroutines .. - EXTERNAL SDLCTN,SDPD3P,SDPLNL,SDTRAN + EXTERNAL GRADC,ICOPY,SDLCTN,SDPD3P,SDPLNL,SDTRAN,TRMESH * .. * .. Intrinsic Functions .. INTRINSIC MIN @@ -109,65 +121,104 @@ SAVE NDPPV,NT,NL * .. * Error check - IF (NDP.LE.9) GO TO 20 + IF (NDP.LE.9) GO TO 30 IF (MD.NE.2 .AND. MD.NE.3) THEN NDPPV = NDP ELSE - IF (NDP.NE.NDPPV) GO TO 30 + IF (NDP.NE.NDPPV) GO TO 40 END IF - IF (NIP.LE.0) GO TO 40 + IF (NIP.LE.0) GO TO 50 * Triangulates the x-y plane. (for MD=1) IF (MD.NE.2 .AND. MD.NE.3) THEN - CALL SDTRAN(NDP,XD,YD, NT,IWK(1,1),NL,IWK(1,7),IERT, - + IWK(1,1),IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9), - + NEAR,NEXT,DIST) -* CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, -* + LIST,LPTR,LEND,LTRI,ITL) - IF (IERT.EQ.2) GO TO 55 - IF (IERT.GT.0) GO TO 50 + CALL TRMESH(NDP,XD,YD,IWK(1,1),IWK(1,7),IWK(1,13),LNEW,IERT) + IF (IERT.EQ.-2) GO TO 55 + IF (IERT.LT.0) GO TO 60 +* Copies triangulation data structure to IWK(1,26). + CALL ICOPY(LNEW-1,IWK(1,1),IWK(1,26)) + CALL ICOPY(LNEW-1,IWK(1,7),IWK(1,32)) + CALL ICOPY(NDP,IWK(1,13),IWK(1,38)) + CALL SDTRAN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),IERT,IWK(1,1), + + IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9),HBRMN,NRRTT) +* CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, +* 1 LIST,LPTR,LEND,LTRI,ITL) + IF (IERT.EQ.6) GO TO 65 + IF (IERT.GT.0) GO TO 60 END IF * Estimates partial derivatives at all data points. (for MD=1,2) - IF (MD.NE.3) THEN - CALL SDPD3P(NDP,XD,YD,ZD, WK(1,1), WK(1,6),WK(1,15),WK(1,17), - + IWK(1,9),IWK(1,10),IWK(1,19)) -* CALL SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP) + IF (MD.NE.3 .AND. (.NOT. LINEAR)) THEN + CALL SDPD3P(NDP,XD,YD,ZD,WK(1,1),WK(1,6),WK(1,15),WK(1,17), + + IWK(1,9),IWK(1,10),IWK(1,19),IWK(1,39)) +* CALL SDPD3P(NDP,XD,YD,ZD, PDD, +* 1 CF3,CFL1,DSQ,IDSQ,IPC,NCP) +* If non-cubic order at node, replace with cubic from GRADC +* agebhard: this uses 5*NDP lines of WK, so increase its size, see above + L = 0 + DO 10 K = 1,NDP + IF (IWK(K,39).LT.3 .AND. (.NOT. LINEAR)) THEN + CALL GRADC(K,0,LCC,NDP,XD,YD,ZD,IWK(1,26),IWK(1,32), + + IWK(1,38),PDX,PDY,PDXX,PDXY,PDYY,IERT) + IF (IERT.GE.0) THEN + J = L/NDP + I = L-NDP*J + J = J + 1 + WK(I+1,J) = PDX + WK(I+2,J) = PDY + WK(I+3,J) = PDXX + WK(I+4,J) = PDXY + WK(I+5,J) = PDYY + END IF + END IF + L = L + 5 + 10 CONTINUE END IF * Locates all points at which interpolation is to be performed * and interpolates the ZI values. (for MD=1,2,3) - DO 10 IIP = 1,NIP,NIPIMX + DO 20 IIP = 1,NIP,NIPIMX NIPI = MIN(NIP-IIP+1,NIPIMX) CALL SDLCTN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),NIPI,XI(IIP), - + YI(IIP), KTLI,ITLI) -* CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI) - CALL SDPLNL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7),WK(1,1),NIPI, - + XI(IIP),YI(IIP),KTLI,ITLI, ZI(IIP), EXTRPI(IIP)) -* CALL SDPLNL(NDP,XD,YD,ZD,NT,IPT,NL,IPL,PDD, -* + NIP,XI,YI,KTLI,ITLI, ZI) - 10 CONTINUE + + YI(IIP),KTLI,ITLI) +* CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL, +* 1 NIP,XI,YI, KTLI,ITLI) + IF (LINEAR) THEN + CALL SDLIPL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7), + + NIPI,XI(IIP),YI(IIP),KTLI,ITLI, ZI(IIP), + + EXTRPI(IIP)) + ELSE + CALL SDPLNL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7),WK(1,1), + + NIPI,XI(IIP),YI(IIP),KTLI,ITLI,ZI(IIP), + + EXTRPI(IIP)) +* CALL SDPLNL(NDP,XD,YD,ZD,NT,IPT,NL,IPL,PDD, +* 1 NIP,XI,YI,KTLI,ITLI, ZI) + END IF + 20 CONTINUE * Normal return IER = 0 RETURN * Error exit - 20 CONTINUE -C WRITE (*,FMT=9000) MD,NDP + 30 CONTINUE +c 30 WRITE (*,FMT=9000) MD,NDP IER = 1 RETURN - 30 CONTINUE -C WRITE (*,FMT=9010) MD,NDP,NDPPV + 40 CONTINUE +c 40 WRITE (*,FMT=9010) MD,NDP,NDPPV IER = 2 RETURN - 40 CONTINUE -C WRITE (*,FMT=9020) MD,NDP,NIP + 50 CONTINUE +c 50 WRITE (*,FMT=9020) MD,NDP,NIP IER = 3 RETURN - 50 CONTINUE -C WRITE (*,FMT=9030) - IER = 9 - RETURN 55 CONTINUE C first three points collinear: IER = 10 RETURN + 60 CONTINUE +c 60 WRITE (*,FMT=9030) + IER = 9 + RETURN + 65 CONTINUE +c triangle removal fails + IER = 11 + RETURN * Format statement for error message 9000 FORMAT (' ',/,'*** SDBI3P Error 1: NDP = 9 or less',/,' MD =', + I5,', NDP =',I5,/) @@ -179,8 +230,8 @@ C first three points collinear: END - SUBROUTINE SDSF3P(MD,NDP,XD,YD,ZD,NXI,XI,NYI,YI, ZI,IER, WK,IWK, - + EXTRPI,NEAR,NEXT,DIST,LINEAR) + SUBROUTINE SDSF3P(MD,NDP,XD,YD,ZD,NXI,XI,NYI,YI,ZI,IER,WK,IWK, + + EXTRPI,LINEAR,HBRMN,NRRTT) * * Scattered-data smooth surface fitting * (a master subroutine of the SDBI3P/SDSF3P subroutine package) @@ -225,18 +276,25 @@ C first three points collinear: * = 2 for NDP not equal to NDPPV * = 3 for NXI = 0 or less * = 4 for NYI = 0 or less -* = 9 for errors in SDTRAN called by this subroutine, except the next one -* =10 for error 2 in SDTRAN (first three points collinear), as this can +* = 9 for errors in SDTRAN and TRMESH called by this subroutine. +* agebhard: +* =10 for error 2 in TRMESH (first three points collinear), as this can * be fixed by adding jitter to the locations in the calling routine. +* =11 if triangle removal fails, caller should rerun with NRRTT=0 * * The other arguments are * WK = two-dimensional array of dimension NDP*36 used * internally as a work area, -* IWK = two-dimensional integer array of dimension NDP*25 +* IWK = two-dimensional integer array of dimension NDP*39 * used internally as a work area. * -* agebhard@uni-klu.ac.at: added from new TRIPACK: -* NEAR, NEXT, DIST work arrays from TRMESH, size NDP +* agebhard: additional arguments: +* LINEAR = switches between splines (Akima) and linear interpolation +* EXTRPI = indicates whether point was extrapolated or not +* HBRMN and NRRTT = (experimental!) params of SDTRTT changed to arguments +* use NRRTT=0 to completely switch off Akimas "remove +* triangles from boundary step", should be default for +* linear interpolation. * * The very first call to this subroutine and the call with a new * NDP value or new XD and YD arrays must be made with MD=1. The @@ -248,11 +306,6 @@ C first three points collinear: * the call with MD=3 and its preceding call, the WK and IWK * arrays must not be disturbed. * -* The user of this subroutine can save the storage, by NDP*6 -* numeric storage units, by placing the statement -* EQUIVALENCE (WK(1,1),IWK(1,20)) -* in the program that calls this subroutine. -* * The constant in the PARAMETER statement below is * NIPIMX = maximum number of output points to be processed * at a time. @@ -261,6 +314,13 @@ C first three points collinear: * This subroutine calls the SDTRAN, SDPD3P, SDLCTN, and SDPLNL * subroutines. * +* It also calls TRMESH from the TRIPACK package of ACM Algorithm +* 751 by R. J. Renka. The TRMESH subroutine in turn calls either +* directly or indirectly 12 other subprograms included in the +* package. In addition, a newly added routine, GRADC, is called +* to compute partial derivatives at those nodes for which the +* cubic fit failed due to ill-conditioning. +* * * Specification statements * .. Parameters .. @@ -268,24 +328,27 @@ C first three points collinear: PARAMETER (NIPIMX=51) * .. * .. Scalar Arguments .. - INTEGER IER,MD,NDP,NXI,NYI,NEAR(NDP),NEXT(NDP) - LOGICAL LINEAR + DOUBLE PRECISION HBRMN + INTEGER IER,MD,NDP,NXI,NYI,NRRTT + LOGICAL LINEAR * .. * .. Array Arguments .. - DOUBLE PRECISION WK(NDP,17),XD(NDP),XI(NXI),YD(NDP), - + YI(NYI),ZD(NDP),ZI(NXI,NYI),DIST(NDP) - INTEGER IWK(NDP,25) +* agebhard: increase linenumber of WK by factor 5! + DOUBLE PRECISION WK(NDP*5,17),XD(NDP),XI(NXI),YD(NDP), + + YI(NYI),ZD(NDP),ZI(NXI,NYI) + INTEGER IWK(NDP,39) LOGICAL EXTRPI(NXI,NYI) * .. * .. Local Scalars .. - INTEGER IERT,IIP,IXI,IYI,NDPPV,NIPI,NL,NT + DOUBLE PRECISION PDX,PDXX,PDXY,PDY,PDYY + INTEGER I,IERT,IIP,IXI,IYI,J,K,L,LNEW,NDPPV,NIPI,NL,NT * .. * .. Local Arrays .. DOUBLE PRECISION YII(NIPIMX) - INTEGER ITLI(NIPIMX),KTLI(NIPIMX) + INTEGER ITLI(NIPIMX),KTLI(NIPIMX),LCC(1) * .. * .. External Subroutines .. - EXTERNAL SDLCTN,SDPD3P,SDPLNL,SDTRAN + EXTERNAL GRADC,ICOPY,SDLCTN,SDPD3P,SDPLNL,SDTRAN,TRMESH * .. * .. Intrinsic Functions .. INTRINSIC MIN @@ -294,82 +357,121 @@ C first three points collinear: SAVE NDPPV,NT,NL * .. * Error check - IF (NDP.LE.9) GO TO 40 + IF (NDP.LE.9) GO TO 50 IF (MD.NE.2 .AND. MD.NE.3) THEN NDPPV = NDP ELSE - IF (NDP.NE.NDPPV) GO TO 50 + IF (NDP.NE.NDPPV) GO TO 60 END IF - IF (NXI.LE.0) GO TO 60 - IF (NYI.LE.0) GO TO 70 + IF (NXI.LE.0) GO TO 70 + IF (NYI.LE.0) GO TO 80 * Triangulates the x-y plane. (for MD=1) IF (MD.NE.2 .AND. MD.NE.3) THEN - CALL SDTRAN(NDP,XD,YD, NT,IWK(1,1),NL,IWK(1,7),IERT, - + IWK(1,1),IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9), - + NEAR,NEXT,DIST) -* CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, -* + LIST,LPTR,LEND,LTRI,ITL) - IF (IERT.EQ.2) GO TO 85 - IF (IERT.GT.0) GO TO 80 + CALL TRMESH(NDP,XD,YD,IWK(1,1),IWK(1,7),IWK(1,13),LNEW,IERT) +* IERT = error flag from the TRMESH subroutine, +* = 0 for no errors +* = -1 for NDP = 3 or less +* = -2 for the first three collinear data points, +* = L for the Lth data point identical to some +* Mth data point, M > L. + IF (IERT.EQ.-2) GO TO 85 + IF (IERT.LT.0) GO TO 90 +* Copies triangulation data structure to IWK(1,26). + CALL ICOPY(LNEW-1,IWK(1,1),IWK(1,26)) + CALL ICOPY(LNEW-1,IWK(1,7),IWK(1,32)) + CALL ICOPY(NDP,IWK(1,13),IWK(1,38)) + CALL SDTRAN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),IERT,IWK(1,1), + + IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9),HBRMN,NRRTT) +* CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, +* 1 LIST,LPTR,LEND,LTRI,ITL) + IF (IERT.EQ.6) GO TO 95 + IF (IERT.GT.0) GO TO 90 END IF * Estimates partial derivatives at all data points. (for MD=1,2) IF (MD.NE.3 .AND. (.NOT. LINEAR)) THEN - CALL SDPD3P(NDP,XD,YD,ZD, WK(1,1), WK(1,6),WK(1,15),WK(1,17), - + IWK(1,9),IWK(1,10),IWK(1,19)) -* CALL SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP) + CALL SDPD3P(NDP,XD,YD,ZD,WK(1,1),WK(1,6),WK(1,15),WK(1,17), + + IWK(1,9),IWK(1,10),IWK(1,19),IWK(1,39)) +* CALL SDPD3P(NDP,XD,YD,ZD, PDD, +* 1 CF3,CFL1,DSQ,IDSQ,IPC,NCP) +* If non-cubic order at node, replace with cubic from GRADC +* agebhard: this uses 5*NDP lines of WK, so increase its size, see above + L = 0 + DO 10 K = 1,NDP + IF (IWK(K,39).LT.3 .AND. (.NOT. LINEAR)) THEN + CALL GRADC(K,0,LCC,NDP,XD,YD,ZD,IWK(1,26),IWK(1,32), + + IWK(1,38),PDX,PDY,PDXX,PDXY,PDYY,IERT) + IF (IERT.GE.0) THEN + J = L/NDP + I = L-NDP*J + J = J + 1 + WK(I+1,J) = PDX + WK(I+2,J) = PDY + WK(I+3,J) = PDXX + WK(I+4,J) = PDXY + WK(I+5,J) = PDYY + END IF + END IF + L = L + 5 + 10 CONTINUE END IF * Locates all grid points at which interpolation is to be * performed and interpolates the ZI values. (for MD=1,2,3) - DO 30 IYI = 1,NYI - DO 10 IIP = 1,NIPIMX + DO 40 IYI = 1,NYI + DO 20 IIP = 1,NIPIMX YII(IIP) = YI(IYI) - 10 CONTINUE - DO 20 IXI = 1,NXI,NIPIMX + 20 CONTINUE + DO 30 IXI = 1,NXI,NIPIMX NIPI = MIN(NXI-IXI+1,NIPIMX) CALL SDLCTN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),NIPI, - + XI(IXI),YII, KTLI,ITLI) -* CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI) + + XI(IXI),YII,KTLI,ITLI) +* CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL, +* 1 NIP,XI,YI, KTLI,ITLI) +* agebhard: add linear interpolation: IF (LINEAR) THEN - CALL SDLIPL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7), - + NIPI,XI(IXI),YII,KTLI,ITLI, ZI(IXI,IYI), - + EXTRPI(IXI,IYI)) + CALL SDLIPL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7), + + NIPI,XI(IXI),YII,KTLI,ITLI, ZI(IXI,IYI), + + EXTRPI(IXI,IYI)) ELSE CALL SDPLNL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7),WK(1,1), - + NIPI,XI(IXI),YII,KTLI,ITLI, ZI(IXI,IYI), + + NIPI,XI(IXI),YII,KTLI,ITLI,ZI(IXI,IYI), + EXTRPI(IXI,IYI)) -* CALL SDPLNL(NDP,XD,YD,ZD,NT,ITP,NL,IPL,PDD, -* + NIP,XI,YI,KTLI,ITLI, ZI) +* CALL SDPLNL(NDP,XD,YD,ZD,NT,ITP,NL,IPL,PDD, +* 1 NIP,XI,YI,KTLI,ITLI, ZI) END IF - 20 CONTINUE - 30 CONTINUE + 30 CONTINUE + 40 CONTINUE * Normal return IER = 0 RETURN * Error exit - 40 CONTINUE -C WRITE (*,FMT=9000) MD,NDP + 50 CONTINUE +c 50 WRITE (*,FMT=9000) MD,NDP IER = 1 RETURN - 50 CONTINUE -C WRITE (*,FMT=9010) MD,NDP,NDPPV + 60 CONTINUE +c 60 WRITE (*,FMT=9010) MD,NDP,NDPPV IER = 2 RETURN - 60 CONTINUE -C WRITE (*,FMT=9020) MD,NDP,NXI,NYI + 70 CONTINUE +c 70 WRITE (*,FMT=9020) MD,NDP,NXI,NYI IER = 3 RETURN - 70 CONTINUE -C WRITE (*,FMT=9030) MD,NDP,NXI,NYI + 80 CONTINUE +c 80 WRITE (*,FMT=9030) MD,NDP,NXI,NYI IER = 4 RETURN - 80 CONTINUE -C WRITE (*,FMT=9040) - IER = 9 - RETURN 85 CONTINUE C first three points collinear: IER = 10 RETURN + 90 CONTINUE +c 90 WRITE (*,FMT=9040) + IER = 9 + RETURN + 95 CONTINUE +c triangle removal fails + IER = 11 + RETURN * Format statement for error message 9000 FORMAT (' ',/,'*** SDSF3P Error 1: NDP = 9 or less',/,' MD =', + I5,', NDP =',I5,/) @@ -383,8 +485,8 @@ C first three points collinear: END - SUBROUTINE SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, LIST,LPTR,LEND, - + LTRI,ITL,NEAR,NEXT,DIST) + SUBROUTINE SDTRAN(NDP,XD,YD,NT,IPT,NL,IPL,IERT,LIST,LPTR,LEND, + + LTRI,ITL,HBRMN,NRRTT) * * Triangulation of the data area in a plane with a scattered data * point set @@ -405,12 +507,19 @@ C first three points collinear: * data area. It calls the SDTRCH and SDTRTT subroutines, that * correspond to Steps (1) and (2), respectively. * +* The SDTRCH subroutine depends on the TRIPACK package of ACM +* Algorithm XXX by R. J. Renka. It calls the TRLIST subroutine +* included in the package. +* * The input arguments are * NDP = number of data points (must be greater than 3), * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points. +* LIST = integer array of dimension 6*NDP returned by TRMESH. +* LPTR = integer array of dimension 6*NDP returned by TRMESH. +* LEND = integer array of dimension NDP returned by TRMESH. * * The output arguments are * NT = number of triangles (its maximum is 2*NDP-5), @@ -430,94 +539,71 @@ C first three points collinear: * IERT = error flag * = 0 for no errors * = 1 for NDP = 3 or less -* = 2 for first three data points are collinear -* = 3 for identical data points -* = 4 for invalid NCC, NDP, or NROW value. -* = 5 for invalid data structure (LIST,LPTR,LEND). +* = 2 for identical data points +* = 3 for all collinear data points. +* agebhard: +* = 6 when triangle removal fails +* HBRMN and NRRTT = (experimental!) params of SDTRTT changed to arguments +* use NRRTT=0 to completely switch off Akimas "remove +* triangles from boundary step", should be default for +* linear interpolation. * * The other arguments are -* LIST = integer array of dimension 6*NDP USED internally -* as a work area, -* LPTR = integer array of dimension 6*NDP USED internally -* as a work area, -* LEND = integer array of dimension NDP USED internally as -* a work area, * LTRI = two-dimensional integer array of dimension 12*NDP * used internally as a work area. * ITL = integer array of dimension NDP used internally as * a work area. * -* agebhard@uni-klu.ac.at: added from new TRIPACK: -* NEAR, NEXT, DIST work arrays from TRMESH, size NDP -* * * Specification statements * .. Scalar Arguments .. - INTEGER IERT,NDP,NL,NT,NEAR(NDP),NEXT(NDP) + DOUBLE PRECISION HBRMN + INTEGER IERT,NDP,NL,NT,NRRTT * .. * .. Array Arguments .. - DOUBLE PRECISION XD(NDP),YD(NDP),DIST(NDP) + DOUBLE PRECISION XD(NDP),YD(NDP) INTEGER IPL(2,*),IPT(3,*),ITL(NDP),LEND(NDP),LIST(6,NDP), + LPTR(6,NDP),LTRI(12,NDP) * .. * .. Local Scalars .. - INTEGER IERTL,IERTM,IP1 + INTEGER IERTL * .. * .. External Subroutines .. EXTERNAL SDTRCH,SDTRTT * .. * Basic triangulation - CALL SDTRCH(NDP,XD,YD, NT,IPT,NL,IPL,IERTM,IERTL, LIST,LPTR,LEND, - + LTRI,NEAR,NEXT,DIST) - IF (IERTM.NE.0) GO TO 10 - IF (IERTL.NE.0) GO TO 20 + CALL SDTRCH(NDP,NT,IPT,NL,IPL,IERTL,LIST,LPTR,LEND,LTRI) + IF (IERTL.NE.0) GO TO 10 IERT = 0 * Removal of thin triangles that share border line segments - CALL SDTRTT(NDP,XD,YD, NT,IPT,NL,IPL, ITL) - RETURN -* Error exit - 10 IF (IERTM.EQ.-1) THEN - IERT = 1 - CONTINUE -C WRITE (*,FMT=9000) NDP - ELSE IF (IERTM.EQ.-2) THEN - IERT = 2 - CONTINUE -C WRITE (*,FMT=9010) - ELSE - IERT = 3 - IP1 = IERTM - CONTINUE -C WRITE (*,FMT=9020) NDP,IP1,XD(IP1),YD(IP1) +* agebhard: +* FIXME: is this necessary at all? at least not for linear interpolation: +* parameter REMOVE=.FALSE. enables skiping + IF (NRRTT.GT.0) THEN + CALL SDTRTT(NDP,XD,YD,NT,IPT,NL,IPL,ITL,HBRMN,NRRTT,IERTL) + IF (IERTL.NE.0) GO TO 10 END IF RETURN - 20 IF (IERTL.EQ.1) THEN +* Error exit + 10 IF (IERTL.EQ.1) THEN IERT = 4 - CONTINUE -C WRITE (*,FMT=9030) NDP +c WRITE (*,FMT=9000) NDP ELSE IF (IERTL.EQ.2) THEN IERT = 5 - CONTINUE -C WRITE (*,FMT=9040) +c WRITE (*,FMT=9010) + ELSE IF (IERTL.EQ.-1) THEN + IERT = 6 END IF RETURN * Format statements - 9000 FORMAT (' ',/,'*** SDTRAN Error 1: NDP = 3 or less',/,' NDP =', - + I5) - 9010 FORMAT (' ',/,'*** SDTRAN Error 2: ', - + 'The first three data points are collinear.',/) - 9020 FORMAT (' ',/,'*** SDTRAN Error 3: Identical data points',/, - + ' NDP =',I5,', IP1 =',I5,', XD =',E11.3,', YD =', - + E11.3) - 9030 FORMAT (' ',/,'*** SDTRAN Error 4: NDP outside its valid', + 9000 FORMAT (' ',/,'*** SDTRAN Error 4: NDP outside its valid', + ' range',/,' NDP =',I5) - 9040 FORMAT (' ',/,'*** SDTRAN Error 5: ', + 9010 FORMAT (' ',/,'*** SDTRAN Error 5: ', + 'Invalid data structure (LIST,LPTR,LEND)',/) END - SUBROUTINE SDTRCH(NDP,XD,YD, NT,IPT,NL,IPL,IERTM,IERTL, - + LIST,LPTR,LEND,LTRI,NEAR,NEXT,DIST) + SUBROUTINE SDTRCH(NDP,NT,IPT,NL,IPL,IERTL,LIST,LPTR,LEND,LTRI) * * Basic triangulation in the convex hull of a scattered data point * set in a plane @@ -533,17 +619,14 @@ C WRITE (*,FMT=9040) * that form the border of the data area. * * This subroutine depends on the TRIPACK package of ACM Algorithm -* 751 by R. J. Renka. It calls the TRMESH and TRLIST subroutines -* included in the package. The TRMESH subroutine in turn calls -* either directly or indirectly 12 other subprograms included in +* 751 by R. J. Renka. It calls the TRLIST subroutine included in * the package. * * The input arguments are * NDP = number of data points (must be greater than 3), -* XD = array of dimension NDP containing the x -* coordinates of the data points, -* YD = array of dimension NDP containing the y -* coordinates of the data points. +* LIST = integer array of dimension 6*NDP returned by TRMESH. +* LPTR = integer array of dimension 6*NDP returned by TRMESH. +* LEND = integer array of dimension NDP returned by TRMESH. * * The output arguments are * NT = number of triangles (its maximum is 2*NDP-5), @@ -560,29 +643,15 @@ C WRITE (*,FMT=9040) * be stored counterclockwise in the ILth column, * where IL = 1, 2, ..., NL, with the line segments * stored counterclockwise, -* IERTM = error flag from the TRMESH subroutine, -* = 0 for no errors -* = -1 for NDP = 3 or less -* = -2 for the first three collinear data points, -* = L for the Lth data point identical to some -* Mth data point, M > L. * IERTL = error flag from the TRLIST subroutine, * = 0 for no errors * = 1 for invalid NCC, NDP, or NROW value. * = 2 for invalid data structure (LIST,LPTR,LEND). * * The other arguments are -* LIST = integer array of dimension 6*NDP USED internally -* as a work area, -* LPTR = integer array of dimension 6*NDP USED internally -* as a work area, -* LEND = integer array of dimension NDP USED internally as -* a work area, * LTRI = two-dimensional integer array of dimension 12*NDP * used internally as a work area. * -* agebhard@uni-klu.ac.at: added from new TRIPACK: -* NEAR, NEXT, DIST work arrays from TRMESH, size NDP * * Specification statements * .. Parameters .. @@ -590,29 +659,26 @@ C WRITE (*,FMT=9040) PARAMETER (NCC=0,NROW=6) * .. * .. Scalar Arguments .. - INTEGER IERTL,IERTM,NDP,NL,NT,NEAR(NDP),NEXT(NDP) + INTEGER IERTL,NDP,NL,NT * .. * .. Array Arguments .. - DOUBLE PRECISION XD(NDP),YD(NDP),DIST(NDP) INTEGER IPL(2,*),IPT(3,*),LEND(NDP),LIST(*),LPTR(*), + LTRI(NROW,*) * .. * .. Local Scalars .. - INTEGER I,I1,I2,IL,IL1,IL2,IPL11,IPL21,J,LNEW + INTEGER I,I1,I2,IL,IL1,IL2,IPL11,IPL21,J * .. * .. Local Arrays .. INTEGER LCC(1),LCT(1) * .. * .. External Subroutines .. - EXTERNAL TRLIST,TRMESH + EXTERNAL TRLIST * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * Performs basic triangulation. - CALL TRMESH(NDP,XD,YD, LIST,LPTR,LEND,LNEW,NEAR,NEXT,DIST,IERTM) - IF (IERTM.NE.0) RETURN - CALL TRLIST(NCC,LCC,NDP,LIST,LPTR,LEND,NROW, NT,LTRI,LCT,IERTL) + CALL TRLIST(NCC,LCC,NDP,LIST,LPTR,LEND,NROW,NT,LTRI,LCT,IERTL) IF (IERTL.NE.0) RETURN * Extracts the triangle data from the LTRI array and set the IPT * array. @@ -624,35 +690,35 @@ C WRITE (*,FMT=9040) * Extracts the border-line-segment data from the LTRI array and * set the IPL array. IL = 0 - DO 50 J = 1,NT + DO 40 J = 1,NT DO 30 I = 1,3 - IF (LTRI(I+3,J).LE.0) GO TO 40 + IF (LTRI(I+3,J).LE.0) THEN + IL = IL + 1 + I1 = MOD(I,3) + 1 + I2 = MOD(I+1,3) + 1 + IPL(1,IL) = LTRI(I1,J) + IPL(2,IL) = LTRI(I2,J) + END IF 30 CONTINUE - GO TO 50 - 40 IL = IL + 1 - I1 = MOD(I,3) + 1 - I2 = MOD(I+1,3) + 1 - IPL(1,IL) = LTRI(I1,J) - IPL(2,IL) = LTRI(I2,J) - 50 CONTINUE + 40 CONTINUE NL = IL * Sorts the IPL array. - DO 80 IL1 = 1,NL - 1 - DO 60 IL2 = IL1 + 1,NL - IF (IPL(1,IL2).EQ.IPL(2,IL1)) GO TO 70 - 60 CONTINUE - 70 IPL11 = IPL(1,IL1+1) + DO 70 IL1 = 1,NL - 1 + DO 50 IL2 = IL1 + 1,NL + IF (IPL(1,IL2).EQ.IPL(2,IL1)) GO TO 60 + 50 CONTINUE + 60 IPL11 = IPL(1,IL1+1) IPL21 = IPL(2,IL1+1) IPL(1,IL1+1) = IPL(1,IL2) IPL(2,IL1+1) = IPL(2,IL2) IPL(1,IL2) = IPL11 IPL(2,IL2) = IPL21 - 80 CONTINUE + 70 CONTINUE RETURN END - SUBROUTINE SDTRTT(NDP,XD,YD, NT,IPT,NL,IPL, ITL) + SUBROUTINE SDTRTT(NDP,XD,YD,NT,IPT,NL,IPL,ITL,HBRMN,NRRTT,IER) * * Removal of thin triangles along the border line of triangulation * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) @@ -696,35 +762,45 @@ C WRITE (*,FMT=9040) * triangle along the border line of the data area, * NRRTT = number of repetitions in thin triangle removal. * The constant values have been selected empirically. +* agebhard: +* change HBRMN and NRRTT to arguments +* IER = -1 : array overrun due to triangle removal in +* strange configuration, e.g.: +* x= 8.0 8.5 9.0 9.5 10.0 10.5 11.0 11.5 12.0 12.5 13.0 +* y= 7.62 36.70 62.30 65.70 73.84 74.26 78.52 83.60 83.94 84.04 87.30 +* will fail with NRRTT>=3 and HBRMN=0.1 * * Specification statements * .. Parameters .. DOUBLE PRECISION HBRMN INTEGER NRRTT - PARAMETER (HBRMN=0.10,NRRTT=5) +* PARAMETER (HBRMN=0.10D0,NRRTT=5) * .. * .. Scalar Arguments .. - INTEGER NDP,NL,NT + INTEGER NDP,NL,NT,IER * .. * .. Array Arguments .. DOUBLE PRECISION XD(NDP),YD(NDP) INTEGER IPL(2,*),IPT(3,*),ITL(NDP) * .. * .. Local Scalars .. - DOUBLE PRECISION HBR,U1,U2,U3,V1,V2,V3 + DOUBLE PRECISION DXA,DYA,HBR,U1,U2,U3,U4,V1,V2,V3,V4 INTEGER IL,IL0,IL00,IL1,ILP1,ILR1,IP1,IP2,IP3,IPL1,IPL2, + IREP,IT,IT0,ITP1,IV,IVP1,MODIF,NL0 * .. * .. Intrinsic Functions .. - INTRINSIC MOD + INTRINSIC DABS,MOD,DBLE * .. * .. Statement Functions .. DOUBLE PRECISION DSQF,VPDT * .. -* Statement Function definitions - DSQF(U1,V1,U2,V2) = (U2-U1)**2 + (V2-V1)**2 - VPDT(U1,V1,U2,V2,U3,V3) = (V3-V1)* (U2-U1) - (U3-U1)* (V2-V1) +* .. Statement Function definitions .. + DSQF(U1,V1,U2,V2,U3,V3) = ((U2-U1)/U3)**2 + ((V2-V1)/V3)**2 + VPDT(U1,V1,U2,V2,U3,V3,U4,V4) = ((V3-V1)/V4)* ((U2-U1)/U4) - + + ((U3-U1)/U4)* ((V2-V1)/V4) * .. +* initialization: + IER=0 * Triangle numbers of triangles that share line segments with the * border line. DO 20 IL = 1,NL @@ -741,13 +817,24 @@ C WRITE (*,FMT=9040) END IF 10 CONTINUE 20 CONTINUE +* Average delta x and y for boundary line segments + DXA = 0.0D0 + DYA = 0.0D0 + DO 30 IL = 1,NL + IP1 = IPL(1,IL) + IP2 = IPL(2,IL) + DXA = DXA + DABS(XD(IP1)-XD(IP2)) + DYA = DYA + DABS(YD(IP1)-YD(IP2)) + 30 CONTINUE + DXA = DXA/DBLE(NL) + DYA = DYA/DBLE(NL) * Removes thin triangles that share line segments with the border * line. - DO 130 IREP = 1,NRRTT + DO 140 IREP = 1,NRRTT MODIF = 0 NL0 = NL IL = 0 - DO 120 IL0 = 1,NL0 + DO 130 IL0 = 1,NL0 IL = IL + 1 IP1 = IPL(1,IL) IP2 = IPL(2,IL) @@ -761,69 +848,86 @@ C WRITE (*,FMT=9040) IP3 = IPT(3,IT) END IF HBR = VPDT(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3), - + YD(IP3))/DSQF(XD(IP1),YD(IP1),XD(IP2),YD(IP2)) + + YD(IP3),DXA,DYA)/DSQF(XD(IP1),YD(IP1),XD(IP2), + + YD(IP2),DXA,DYA) IF (HBR.LT.HBRMN) THEN MODIF = 1 * Removes this triangle when applicable. ITP1 = IT + 1 - DO 30 IT0 = ITP1,NT + DO 40 IT0 = ITP1,NT IPT(1,IT0-1) = IPT(1,IT0) IPT(2,IT0-1) = IPT(2,IT0) IPT(3,IT0-1) = IPT(3,IT0) - 30 CONTINUE - NT = NT - 1 - DO 40 IL00 = 1,NL - IF (ITL(IL00).GT.IT) ITL(IL00) = ITL(IL00) - 1 40 CONTINUE + NT = NT - 1 + DO 50 IL00 = 1,NL +* agebhard:check for array overrun in ITL, indicates problems with +* triangle removal, report back (IER=-1) to caller and retry without +* triangle removal (TODO: autmatically retry with decreased NTTRR) + IF ((IL00).LE.NDP) THEN + IF (ITL(IL00).GT.IT) ITL(IL00) = ITL(IL00) - 1 + ELSE + IER=-1 + RETURN + END IF + 50 CONTINUE * Replaces the border line segment with two new line segments. IF (IL.LT.NL) THEN ILP1 = IL + 1 - DO 50 ILR1 = ILP1,NL + DO 60 ILR1 = ILP1,NL IL1 = NL + ILP1 - ILR1 IPL(1,IL1+1) = IPL(1,IL1) IPL(2,IL1+1) = IPL(2,IL1) - ITL(IL1+1) = ITL(IL1) - 50 CONTINUE +* agebhard: check for array overrun in ITL, indicates problems with +* triangle removal, report back to caller and retry without +* triangle removal (TODO: autmatically retry with decreased NTTRR) + IF ((IL1+1).LE.NDP) THEN + ITL(IL1+1) = ITL(IL1) + ELSE + IER=-1 + RETURN + END IF + 60 CONTINUE END IF * - Adds the first new line segment. IPL(1,IL) = IP1 IPL(2,IL) = IP3 - DO 70 IT0 = 1,NT - DO 60 IV = 1,3 + DO 80 IT0 = 1,NT + DO 70 IV = 1,3 IF (IPT(IV,IT0).EQ.IP1 .OR. + IPT(IV,IT0).EQ.IP3) THEN IVP1 = MOD(IV,3) + 1 IF (IPT(IVP1,IT0).EQ.IP1 .OR. - + IPT(IVP1,IT0).EQ.IP3) GO TO 80 + + IPT(IVP1,IT0).EQ.IP3) GO TO 90 END IF - 60 CONTINUE - 70 CONTINUE - 80 ITL(IL) = IT0 + 70 CONTINUE + 80 CONTINUE + 90 ITL(IL) = IT0 * - Adds the second new line segment. IL = IL + 1 IPL(1,IL) = IP3 IPL(2,IL) = IP2 - DO 100 IT0 = 1,NT - DO 90 IV = 1,3 + DO 110 IT0 = 1,NT + DO 100 IV = 1,3 IF (IPT(IV,IT0).EQ.IP3 .OR. + IPT(IV,IT0).EQ.IP2) THEN IVP1 = MOD(IV,3) + 1 IF (IPT(IVP1,IT0).EQ.IP3 .OR. - + IPT(IVP1,IT0).EQ.IP2) GO TO 110 + + IPT(IVP1,IT0).EQ.IP2) GO TO 120 END IF - 90 CONTINUE - 100 CONTINUE - 110 ITL(IL) = IT0 + 100 CONTINUE + 110 CONTINUE + 120 ITL(IL) = IT0 NL = NL + 1 END IF - 120 CONTINUE + 130 CONTINUE IF (MODIF.EQ.0) RETURN - 130 CONTINUE + 140 CONTINUE RETURN END - SUBROUTINE SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP) + SUBROUTINE SDPD3P(NDP,XD,YD,ZD,PDD,CF3,CFL1,DSQ,IDSQ,IPC,NCP,IORD) * * Partial derivatives for bivariate interpolation and surface * fitting for scattered data @@ -848,11 +952,13 @@ C WRITE (*,FMT=9040) * ZD = array of dimension NDP containing the z values * at the data points. * -* The output argument is +* The output arguments are * PDD = two-dimensional array of dimension 5*NDP, where * the estimated zx, zy, zxx, zxy, and zyy values * at the IDPth data point are to be stored in the * IDPth row, where IDP = 1, 2, ..., NDP. +* IORD = integer array of dimension NDP containing the +* degree of the polynomial used to compute PDD. * * The other arguments are * CF3 = two-dimensional array of dimension 9*NDP used @@ -895,7 +1001,7 @@ C WRITE (*,FMT=9040) * .. Array Arguments .. DOUBLE PRECISION CF3(9,NDP),CFL1(2,NDP),DSQ(NDP), + PDD(5,NDP),XD(NDP),YD(NDP),ZD(NDP) - INTEGER IDSQ(NDP),IPC(9,NDP),NCP(NDP) + INTEGER IDSQ(NDP),IORD(NDP),IPC(9,NDP),NCP(NDP) * .. * .. Local Scalars .. DOUBLE PRECISION A01,A02,A03,A10,A11,A12,A20,A21,A30, @@ -912,19 +1018,19 @@ C WRITE (*,FMT=9040) EXTERNAL SDCF3P,SDCLDP,SDLS1P * .. * .. Intrinsic Functions .. - INTRINSIC EXP,DBLE + INTRINSIC DEXP,DBLE * .. * Calculation * Selects, at each of the data points, nine data points closest * to the data point in question. - CALL SDCLDP(NDP,XD,YD, IPC, DSQ,IDSQ) + CALL SDCLDP(NDP,XD,YD,IPC,DSQ,IDSQ) * Fits, at each of the data points, a cubic (third-degree) * polynomial to z values at the 10 data points that consist of * the data point in question and 9 data points closest to it. - CALL SDCF3P(NDP,XD,YD,ZD,IPC, CF3,NCP) + CALL SDCF3P(NDP,XD,YD,ZD,IPC,CF3,NCP,IORD) * Performs, at each of the data points, the least-squares fit of * a plane to z values at the 10 data points. - CALL SDLS1P(NDP,XD,YD,ZD,IPC,NCP, CFL1) + CALL SDLS1P(NDP,XD,YD,ZD,IPC,NCP,CFL1) * Outermost DO-loop with respect to the data point DO 310 IDP1 = 1,NDP * Selects data point sets for sets of primary estimates of partial @@ -1025,37 +1131,46 @@ C WRITE (*,FMT=9040) A02 = CF3(7,IDPI) A12 = CF3(8,IDPI) A03 = CF3(9,IDPI) - PDPE(1,IPE) = A10 + X* (2.0*A20+X*3.0*A30) + - + Y* (A11+2.0*A21*X+A12*Y) - PDPE(2,IPE) = A01 + Y* (2.0*A02+Y*3.0*A03) + - + X* (A11+2.0*A12*Y+A21*X) - PDPE(3,IPE) = 2.0*A20 + 6.0*A30*X + 2.0*A21*Y - PDPE(4,IPE) = A11 + 2.0*A21*X + 2.0*A12*Y - PDPE(5,IPE) = 2.0*A02 + 6.0*A03*Y + 2.0*A12*X + PDPE(1,IPE) = A10 + X* (2.0D0*A20+X*3.0D0*A30) + + + Y* (A11+2.0D0*A21*X+A12*Y) + PDPE(2,IPE) = A01 + Y* (2.0D0*A02+Y*3.0D0*A03) + + + X* (A11+2.0D0*A12*Y+A21*X) + PDPE(3,IPE) = 2.0D0*A20 + 6.0D0*A30*X + 2.0D0*A21*Y + PDPE(4,IPE) = A11 + 2.0D0*A21*X + 2.0D0*A12*Y + PDPE(5,IPE) = 2.0D0*A02 + 6.0D0*A03*Y + 2.0D0*A12*X 170 CONTINUE IF (NPE.EQ.1) GO TO 290 -* Weighted values of partial derivatives (through the statement -* labeled 280 + 1) +* Weighted values of partial derivatives. +* * Calculates the probability weight. ANPE = DBLE(NPE) ANPEM1 = DBLE(NPE-1) DO 190 K = 1,5 - AMPDPE(K) = 0.0 - SSPDPE(K) = 0.0 + AMPDPE(K) = 0.0D0 +*DELETED from Valtulina SSPDPE(K) = 0.0 DO 180 IPE = 1,NPE AMPDPE(K) = AMPDPE(K) + PDPE(K,IPE) - SSPDPE(K) = SSPDPE(K) + PDPE(K,IPE)**2 +*DELETED from Valtulina SSPDPE(K) = SSPDPE(K) + PDPE(K,IPE)**2 180 CONTINUE AMPDPE(K) = AMPDPE(K)/ANPE - SSPDPE(K) = (SSPDPE(K)-ANPE*AMPDPE(K)**2)/ANPEM1 +*DELETED from Valtulina SSPDPE(K) = (SSPDPE(K)-ANPE*AMPDPE(K)**2)/ANPEM1 190 CONTINUE +* ADDED from Valtulina +* Calculates the unbiased estimate of variance + DO 191 K=1,5 + SSPDPE(K) = 0.0D0 + DO 181 IPE = 1,NPE + SSPDPE(K) = SSPDPE(K)+(PDPE(K,IPE)-AMPDPE(K))**2 + 181 CONTINUE + SSPDPE(K) = SSPDPE(K)/ANPEM1 + 191 CONTINUE DO 210 IPE = 1,NPE - ALPWT = 0.0 + ALPWT = 0.0D0 DO 200 K = 1,5 - IF (SSPDPE(K).NE.0.0) ALPWT = ALPWT + + IF (SSPDPE(K).NE.0.0D0) ALPWT = ALPWT + + ((PDPE(K,IPE)-AMPDPE(K))**2)/SSPDPE(K) 200 CONTINUE - PWT(IPE) = EXP(-ALPWT/2.0) + PWT(IPE) = DEXP(-ALPWT/2.0D0) 210 CONTINUE * Calculates the reciprocal of the volatility weight. DO 220 IPE = 1,NPE @@ -1063,24 +1178,25 @@ C WRITE (*,FMT=9040) ZX = CFL1(1,IDPI) ZY = CFL1(2,IDPI) RVWT(IPE) = ((PDPE(1,IPE)-ZX)**2+ (PDPE(2,IPE)-ZY)**2)* - + (PDPE(3,IPE)**2+2.0*PDPE(4,IPE)**2+ + + (PDPE(3,IPE)**2+2.0D0*PDPE(4,IPE)**2+ + PDPE(5,IPE)**2) -* ZXX=0.0 -* ZXY=0.0 -* ZYY=0.0 -* RVWT(IPE)=((PDPE(1,IPE)-ZX)**2+(PDPE(2,IPE)-ZY)**2) -* + *((PDPE(3,IPE)-ZXX)**2+2.0*(PDPE(4,IPE)-ZXY)**2 -* + +(PDPE(5,IPE)-ZYY)**2) +* ZXX=0.0 +* ZXY=0.0 +* ZYY=0.0 +* RVWT(IPE)=((PDPE(1,IPE)-ZX)**2+(PDPE(2,IPE)-ZY)**2) +* 1 *((PDPE(3,IPE)-ZXX)**2+2.0*(PDPE(4,IPE)-ZXY)**2 +* 2 +(PDPE(5,IPE)-ZYY)**2) 220 CONTINUE * Calculates the weighted values of partial derivatives. DO 230 K = 1,5 - PDDIF(K) = 0.0 - PDDII(K) = 0.0 + PDDIF(K) = 0.0D0 + PDDII(K) = 0.0D0 230 CONTINUE - SMWTF = 0.0 - SMWTI = 0.0 + SMWTF = 0.0D0 + SMWTI = 0.0D0 DO 260 IPE = 1,NPE - IF (RVWT(IPE).GT.0.0) THEN +*CHANGED from Valtulina : IF (RVWT(IPE).GT.0.0) THEN + IF (RVWT(IPE).GT.1.0D-38) THEN WTF = PWT(IPE)/RVWT(IPE) DO 240 K = 1,5 PDDIF(K) = PDDIF(K) + PDPE(K,IPE)*WTF @@ -1094,7 +1210,7 @@ C WRITE (*,FMT=9040) SMWTI = SMWTI + WTI END IF 260 CONTINUE - IF (SMWTI.LE.0.0) THEN + IF (SMWTI.LE.0.0D0) THEN DO 270 K = 1,5 PDD(K,IDP1) = PDDIF(K)/SMWTF 270 CONTINUE @@ -1113,7 +1229,7 @@ C WRITE (*,FMT=9040) END - SUBROUTINE SDCLDP(NDP,XD,YD, IPC, DSQ,IDSQ) + SUBROUTINE SDCLDP(NDP,XD,YD,IPC,DSQ,IDSQ) * * Closest data points * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) @@ -1175,7 +1291,7 @@ C WRITE (*,FMT=9040) IDSQ(IDP) = 1 DSQ(IDP) = DSQ(1) IDSQ(1) = IDP - DSQ(1) = 0.0 + DSQ(1) = 0.0D0 * Selects nine data points closest to the IDPth data point and * stores the data point numbers in the IPC array. JIPCMX = MIN(NDP-1,10) @@ -1202,7 +1318,7 @@ C WRITE (*,FMT=9040) END - SUBROUTINE SDCF3P(NDP,XD,YD,ZD,IPC, CF,NCP) + SUBROUTINE SDCF3P(NDP,XD,YD,ZD,IPC,CF,NCP,IORD) * * Coefficients of the third-degree polynomial for z(x,y) * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) @@ -1253,6 +1369,8 @@ C WRITE (*,FMT=9040) * ..., NDP, * NCP = integer array of dimension NDP, where the numbers * of the closest points used are to be stored. +* IORD = integer array of dimension NDP containing the +* degree of the polynomial used to compute PDD. * * The constant in the first PARAMETER statement below is * CNRMX = maximum value of the ratio of the condition @@ -1270,7 +1388,8 @@ C WRITE (*,FMT=9040) * Specification statements * .. Parameters .. DOUBLE PRECISION CNRMX - PARAMETER (CNRMX=1.5E+04) +*CHANGED from Valtulina : PARAMETER (CNRMX=1.5E+04) + PARAMETER (CNRMX=3.5E+07) INTEGER N1,N2,N3 PARAMETER (N1=3,N2=6,N3=10) * .. @@ -1279,7 +1398,7 @@ C WRITE (*,FMT=9040) * .. * .. Array Arguments .. DOUBLE PRECISION CF(9,NDP),XD(NDP),YD(NDP),ZD(NDP) - INTEGER IPC(9,NDP),NCP(NDP) + INTEGER IORD(NDP),IPC(9,NDP),NCP(NDP) * .. * .. Local Scalars .. DOUBLE PRECISION CN,DET,X,X1,X2,Y,Y1,Y2,Z1,Z2 @@ -1299,7 +1418,7 @@ C WRITE (*,FMT=9040) * Main DO-loop with respect to the data point DO 60 IDP = 1,NDP DO 10 J = 1,9 - CF(J,IDP) = 0.0 + CF(J,IDP) = 0.0D0 10 CONTINUE * Calculates the coefficients of the set of linear equations * with the 10-point data point set. @@ -1311,7 +1430,7 @@ C WRITE (*,FMT=9040) END IF X = XD(IDPI) Y = YD(IDPI) - AA3(I,1) = 1.0 + AA3(I,1) = 1.0D0 AA3(I,2) = X AA3(I,3) = X*X AA3(I,4) = X*X*X @@ -1324,15 +1443,16 @@ C WRITE (*,FMT=9040) B(I) = ZD(IDPI) 20 CONTINUE * Solves the set of linear equations. - CALL SDLEQN(N3,AA3,B, CFI,DET,CN, K,EE,ZZ) + CALL SDLEQN(N3,AA3,B,CFI,DET,CN,K,EE,ZZ) * Stores the calculated results as the coefficients of the * third-degree polynomial when applicable. - IF (DET.NE.0.0) THEN + IF (DET.NE.0.0D0) THEN IF (CN.LE.CNRMX*DBLE(N3)) THEN DO 30 J = 2,N3 CF(J-1,IDP) = CFI(J) 30 CONTINUE NCP(IDP) = N3 - 1 + IORD(IDP) = 3 GO TO 60 END IF END IF @@ -1346,7 +1466,7 @@ C WRITE (*,FMT=9040) END IF X = XD(IDPI) Y = YD(IDPI) - AA2(I,1) = 1.0 + AA2(I,1) = 1.0D0 AA2(I,2) = X AA2(I,3) = X*X AA2(I,4) = Y @@ -1355,10 +1475,10 @@ C WRITE (*,FMT=9040) B(I) = ZD(IDPI) 40 CONTINUE * Solves the set of linear equations. - CALL SDLEQN(N2,AA2,B, CFI,DET,CN, K,EE,ZZ) + CALL SDLEQN(N2,AA2,B,CFI,DET,CN,K,EE,ZZ) * Stores the calculated results as the coefficients of the * second-degree polynomial when applicable. - IF (DET.NE.0.0) THEN + IF (DET.NE.0.0D0) THEN IF (CN.LE.CNRMX*DBLE(N2)) THEN CF(1,IDP) = CFI(2) CF(2,IDP) = CFI(3) @@ -1366,6 +1486,7 @@ C WRITE (*,FMT=9040) CF(5,IDP) = CFI(5) CF(7,IDP) = CFI(6) NCP(IDP) = N2 - 1 + IORD(IDP) = 2 GO TO 60 END IF END IF @@ -1375,20 +1496,21 @@ C WRITE (*,FMT=9040) IDPI = IPC(I,IDP) X = XD(IDPI) Y = YD(IDPI) - AA1(I,1) = 1.0 + AA1(I,1) = 1.0D0 AA1(I,2) = X AA1(I,3) = Y B(I) = ZD(IDPI) 50 CONTINUE * Solves the set of linear equations. - CALL SDLEQN(N1,AA1,B, CFI,DET,CN, K,EE,ZZ) + CALL SDLEQN(N1,AA1,B,CFI,DET,CN,K,EE,ZZ) * Stores the calculated results as the coefficients of the * first-degree polynomial when applicable. - IF (DET.NE.0.0) THEN + IF (DET.NE.0.0D0) THEN IF (CN.LE.CNRMX*DBLE(N1)) THEN CF(1,IDP) = CFI(2) CF(4,IDP) = CFI(3) NCP(IDP) = N1 + IORD(IDP) = 1 GO TO 60 END IF END IF @@ -1405,12 +1527,13 @@ C WRITE (*,FMT=9040) CF(1,IDP) = (X2-X1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2) CF(4,IDP) = (Y2-Y1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2) NCP(IDP) = 1 + IORD(NDP) = 0 60 CONTINUE RETURN END - SUBROUTINE SDLEQN(N,AA,B, X,DET,CN, K,EE,ZZ) + SUBROUTINE SDLEQN(N,AA,B,X,DET,CN,K,EE,ZZ) * * Solution of a set of linear equations * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) @@ -1453,32 +1576,38 @@ C WRITE (*,FMT=9040) INTEGER K(N) * .. * .. Local Scalars .. - DOUBLE PRECISION AAIIJ,AAIJIJ,AAIJMX,AAMX,SA,SZ + DOUBLE PRECISION AANORM, ASOM, ZSOM, ZZNORM + DOUBLE PRECISION AAIIJ,AAIJIJ,AAIJMX,AAMX INTEGER I,IJ,IJP1,IJR,J,JJ,JMX,KJMX * .. * .. Intrinsic Functions .. - INTRINSIC ABS,SQRT + INTRINSIC DABS * .. * Calculation * Initial setting DO 10 J = 1,N K(J) = J 10 CONTINUE +*ADDED from Valtulina : calculation of AANORM=NORMinf(AA) + AANORM=0.0D0 DO 30 I = 1,N + ASOM=0.0D0 DO 20 J = 1,N - EE(I,J) = 0.0 + EE(I,J) = 0.0D0 + ASOM=ASOM+DABS(AA(I,J)) 20 CONTINUE - EE(I,I) = 1.0 + EE(I,I) = 1.0D0 + IF (ASOM.GT.AANORM) AANORM=ASOM 30 CONTINUE * Calculation of inverse matrix of AA DO 110 IJ = 1,N * Finds out the element having the maximum absolute value in the * IJ th row. - AAMX = ABS(AA(IJ,IJ)) + AAMX = DABS(AA(IJ,IJ)) JMX = IJ DO 40 J = IJ,N - IF (ABS(AA(IJ,J)).GT.AAMX) THEN - AAMX = ABS(AA(IJ,J)) + IF (DABS(AA(IJ,J)).GT.AAMX) THEN + AAMX = DABS(AA(IJ,J)) JMX = J END IF 40 CONTINUE @@ -1494,7 +1623,8 @@ C WRITE (*,FMT=9040) K(JMX) = KJMX * Makes the diagonal element to be unity. AAIJIJ = AA(IJ,IJ) - IF (AAIJIJ.EQ.0.0) GO TO 210 +*CHANGED from Valtulina : IF (AAIJIJ.EQ.0.0) GO TO 210 + IF (DABS(AAIJIJ).LT.1.0D-8) GO TO 210 DO 60 J = IJ,N AA(IJ,J) = AA(IJ,J)/AAIJIJ 60 CONTINUE @@ -1515,11 +1645,21 @@ C WRITE (*,FMT=9040) 100 CONTINUE END IF * Calculates the determinant. - IF (IJ.EQ.1) THEN - DET = 1.0 - END IF - DET = DET*AAIJIJ* ((-1)** (IJ+JMX)) +*DELETED from Valtulina +*DELETED IF (IJ.EQ.1) THEN +*DELETED DET = 0.0 +*DELETED SGN = 1.0 +*DELETED END IF +*DELETED SGN = SGN* ((-1)** (IJ+JMX)) +*DELETED DET = DET + LOG(ABS(AAIJIJ)) 110 CONTINUE +*DELETED IF (DET.LT.85.0) THEN +*DELETED DET = SGN*EXP(DET) +*DELETED ELSE +*DELETED DET = SGN*1.0E38 +*DELETED END IF +*ADDED from Valtulina : at this point DET must be not equal 0 + DET=1.0D0 * Calculates the elements of the inverse matrix. DO 140 IJR = 1,N IJ = N + 1 - IJR @@ -1539,18 +1679,24 @@ C WRITE (*,FMT=9040) 150 CONTINUE 160 CONTINUE * Calculation of the condition number of AA - SA = 0.0 - SZ = 0.0 +*ADDED from Valtulina : calculation of ZZNORM=NORMinf(ZZ) +*DELETED SA = 0.0 +*DELETED SZ = 0.0 + ZZNORM=0.0D0 DO 180 I = 1,N + ZSOM=0.0D0 DO 170 J = 1,N - SA = SA + AA(I,J)*AA(J,I) - SZ = SZ + ZZ(I,J)*ZZ(J,I) +*DELETED SA = SA + AA(I,J)*AA(J,I) +*DELETED SZ = SZ + ZZ(I,J)*ZZ(J,I) + ZSOM=ZSOM+DABS(ZZ(I,J)) 170 CONTINUE + IF (ZSOM.GT.ZZNORM) ZZNORM=ZSOM 180 CONTINUE - CN = SQRT(ABS(SA*SZ)) +*DELETED CN = SQRT(ABS(SA*SZ)) + CN=AANORM*ZZNORM * Calculation of X vector DO 200 I = 1,N - X(I) = 0.0 + X(I) = 0.0D0 DO 190 J = 1,N X(I) = X(I) + ZZ(I,J)*B(J) 190 CONTINUE @@ -1558,14 +1704,14 @@ C WRITE (*,FMT=9040) RETURN * Special case where the determinant is zero 210 DO 220 I = 1,N - X(I) = 0.0 + X(I) = 0.0D0 220 CONTINUE - DET = 0.0 + DET = 0.0D0 RETURN END - SUBROUTINE SDLS1P(NDP,XD,YD,ZD,IPC,NCP, CFL1) + SUBROUTINE SDLS1P(NDP,XD,YD,ZD,IPC,NCP,CFL1) * * Least squares fit of a linear surface (plane) to z(x,y) values * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) @@ -1624,14 +1770,14 @@ C WRITE (*,FMT=9040) NPLS = NCP(IDP) + 1 IF (NPLS.EQ.2) GO TO 20 * Performs the least squares fit of a plane. - SX = 0.0 - SY = 0.0 - SXX = 0.0 - SXY = 0.0 - SYY = 0.0 - SZ = 0.0 - SXZ = 0.0 - SYZ = 0.0 + SX = 0.0D0 + SY = 0.0D0 + SXX = 0.0D0 + SXY = 0.0D0 + SYY = 0.0D0 + SZ = 0.0D0 + SXZ = 0.0D0 + SYZ = 0.0D0 DO 10 I = 1,NPLS IF (I.EQ.1) THEN IDPI = IDP @@ -1675,7 +1821,7 @@ C WRITE (*,FMT=9040) END - SUBROUTINE SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI) + SUBROUTINE SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI,KTLI,ITLI) * * Locating points in a scattered data point set * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) @@ -1741,7 +1887,7 @@ C WRITE (*,FMT=9040) * .. * .. Local Scalars .. DOUBLE PRECISION U1,U2,U3,V1,V2,V3,X0,X1,X2,X3,Y0,Y1, - + Y2,Y3 + + Y2,Y3 INTEGER IIP,IL1,IL2,ILII,IP1,IP2,IP3,ITII,ITLIPV,KTLIPV * .. * .. Intrinsic Functions .. @@ -1750,7 +1896,7 @@ C WRITE (*,FMT=9040) * .. Statement Functions .. DOUBLE PRECISION SPDT,VPDT * .. -* Statement Function definitions +* .. Statement Function definitions .. SPDT(U1,V1,U2,V2,U3,V3) = (U1-U3)* (U2-U3) + (V1-V3)* (V2-V3) VPDT(U1,V1,U2,V2,U3,V3) = (U1-U3)* (V2-V3) - (V1-V3)* (U2-U3) * .. @@ -1777,9 +1923,9 @@ C WRITE (*,FMT=9040) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) - IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0) .AND. - + (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0) .AND. - + (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0)) THEN + IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0D0) .AND. + + (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0D0) .AND. + + (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0D0)) THEN KTLI(IIP) = 1 ITLI(IIP) = ITII GO TO 40 @@ -1796,9 +1942,9 @@ C WRITE (*,FMT=9040) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) - IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0) .AND. - + (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0) .AND. - + (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0)) THEN + IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0D0) .AND. + + (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0D0) .AND. + + (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0D0)) THEN KTLI(IIP) = 1 ITLI(IIP) = ITII GO TO 40 @@ -1817,18 +1963,18 @@ C WRITE (*,FMT=9040) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) - IF (VPDT(X1,Y1,X3,Y3,X0,Y0).LE.0.0) THEN - IF (VPDT(X1,Y1,X3,Y3,X2,Y2).LE.0.0) THEN - IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).LE.0.0) .AND. - + (SPDT(X3,Y3,X0,Y0,X2,Y2).LE.0.0)) THEN + IF (VPDT(X1,Y1,X3,Y3,X0,Y0).LE.0.0D0) THEN + IF (VPDT(X1,Y1,X3,Y3,X2,Y2).LE.0.0D0) THEN + IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).LE.0.0D0) .AND. + + (SPDT(X3,Y3,X0,Y0,X2,Y2).LE.0.0D0)) THEN KTLI(IIP) = 3 ITLI(IIP) = IL2 GO TO 40 END IF END IF - IF (VPDT(X1,Y1,X3,Y3,X2,Y2).GE.0.0) THEN - IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).GE.0.0) .AND. - + (SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0)) THEN + IF (VPDT(X1,Y1,X3,Y3,X2,Y2).GE.0.0D0) THEN + IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).GE.0.0D0) .AND. + + (SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0D0)) THEN KTLI(IIP) = 4 ITLI(IIP) = IL2 GO TO 40 @@ -1844,9 +1990,9 @@ C WRITE (*,FMT=9040) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) - IF (VPDT(X2,Y2,X3,Y3,X0,Y0).LE.0.0) THEN - IF ((SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0) .AND. - + (SPDT(X2,Y2,X0,Y0,X3,Y3).GE.0.0)) THEN + IF (VPDT(X2,Y2,X3,Y3,X0,Y0).LE.0.0D0) THEN + IF ((SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0D0) .AND. + + (SPDT(X2,Y2,X0,Y0,X3,Y3).GE.0.0D0)) THEN KTLI(IIP) = 2 ITLI(IIP) = IL2 GO TO 40 @@ -1858,7 +2004,7 @@ C WRITE (*,FMT=9040) SUBROUTINE SDPLNL(NDP,XD,YD,ZD,NT,IPT,NL,IPL,PDD,NIP,XI,YI,KTLI, - + ITLI, ZI, EXTRPI) + + ITLI,ZI,EXTRPI) * * Polynomials * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) @@ -1918,6 +2064,8 @@ C WRITE (*,FMT=9040) * The output argument is * ZI = array of dimension NIP, where the calculated z * values are to be stored. +* +* agebhard: * EXTRPI = logical array of dimension NIP, indicating * if a point resides outside the convex hull (and its Z value * has been extrapolated) @@ -2015,41 +2163,41 @@ C WRITE (*,FMT=9040) P00 = Z(1) P10 = ZU(1) P01 = ZV(1) - P20 = 0.5*ZUU(1) + P20 = 0.5D0*ZUU(1) P11 = ZUV(1) - P02 = 0.5*ZVV(1) + P02 = 0.5D0*ZVV(1) H1 = Z(2) - P00 - P10 - P20 H2 = ZU(2) - P10 - ZUU(1) H3 = ZUU(2) - ZUU(1) - P30 = 10.0*H1 - 4.0*H2 + 0.5*H3 - P40 = -15.0*H1 + 7.0*H2 - H3 - P50 = 6.0*H1 - 3.0*H2 + 0.5*H3 + P30 = 10.0D0*H1 - 4.0D0*H2 + 0.5D0*H3 + P40 = -15.0D0*H1 + 7.0D0*H2 - H3 + P50 = 6.0D0*H1 - 3.0D0*H2 + 0.5D0*H3 H1 = Z(3) - P00 - P01 - P02 H2 = ZV(3) - P01 - ZVV(1) H3 = ZVV(3) - ZVV(1) - P03 = 10.0*H1 - 4.0*H2 + 0.5*H3 - P04 = -15.0*H1 + 7.0*H2 - H3 - P05 = 6.0*H1 - 3.0*H2 + 0.5*H3 + P03 = 10.0D0*H1 - 4.0D0*H2 + 0.5D0*H3 + P04 = -15.0D0*H1 + 7.0D0*H2 - H3 + P05 = 6.0D0*H1 - 3.0D0*H2 + 0.5D0*H3 LUSQ = AA + CC LVSQ = BB + DD SPUV = AB + CD - P41 = 5.0*SPUV/LUSQ*P50 - P14 = 5.0*SPUV/LVSQ*P05 + P41 = 5.0D0*SPUV/LUSQ*P50 + P14 = 5.0D0*SPUV/LVSQ*P05 H1 = ZV(2) - P01 - P11 - P41 - H2 = ZUV(2) - P11 - 4.0*P41 - P21 = 3.0*H1 - H2 - P31 = -2.0*H1 + H2 + H2 = ZUV(2) - P11 - 4.0D0*P41 + P21 = 3.0D0*H1 - H2 + P31 = -2.0D0*H1 + H2 H1 = ZU(3) - P10 - P11 - P14 - H2 = ZUV(3) - P11 - 4.0*P14 - P12 = 3.0*H1 - H2 - P13 = -2.0*H1 + H2 + H2 = ZUV(3) - P11 - 4.0D0*P14 + P12 = 3.0D0*H1 - H2 + P13 = -2.0D0*H1 + H2 E1 = (LVSQ-SPUV)/ ((LVSQ-SPUV)+ (LUSQ-SPUV)) - E2 = 1.0 - E1 - G1 = 5.0*E1 - 2.0 - G2 = 1.0 - G1 - H1 = 5.0* (E1* (P50-P41)+E2* (P05-P14)) + (P41+P14) - H2 = 0.5*ZVV(2) - P02 - P12 - H3 = 0.5*ZUU(3) - P20 - P21 + E2 = 1.0D0 - E1 + G1 = 5.0D0*E1 - 2.0D0 + G2 = 1.0D0 - G1 + H1 = 5.0D0* (E1* (P50-P41)+E2* (P05-P14)) + (P41+P14) + H2 = 0.5D0*ZVV(2) - P02 - P12 + H3 = 0.5D0*ZUU(3) - P20 - P21 P22 = H1 + G1*H2 + G2*H3 P32 = H2 - P22 P23 = H3 - P22 @@ -2103,13 +2251,13 @@ C WRITE (*,FMT=9040) * Converts the partial derivatives at the end points of the * border line segment for the u-v coordinate system. AA = A*A - ACT2 = 2.0*A*C + ACT2 = 2.0D0*A*C CC = C*C AB = A*B ADBC = AD + BC CD = C*D BB = B*B - BDT2 = 2.0*B*D + BDT2 = 2.0D0*B*D DD = D*D DO 60 I = 1,2 ZU(I) = A*PD(1,I) + C*PD(2,I) @@ -2122,20 +2270,20 @@ C WRITE (*,FMT=9040) P00 = Z(1) P10 = ZU(1) P01 = ZV(1) - P20 = 0.5*ZUU(1) + P20 = 0.5D0*ZUU(1) P11 = ZUV(1) - P02 = 0.5*ZVV(1) + P02 = 0.5D0*ZVV(1) H1 = Z(2) - P00 - P01 - P02 H2 = ZV(2) - P01 - ZVV(1) H3 = ZVV(2) - ZVV(1) - P03 = 10.0*H1 - 4.0*H2 + 0.5*H3 - P04 = -15.0*H1 + 7.0*H2 - H3 - P05 = 6.0*H1 - 3.0*H2 + 0.5*H3 + P03 = 10.0D0*H1 - 4.0D0*H2 + 0.5D0*H3 + P04 = -15.0D0*H1 + 7.0D0*H2 - H3 + P05 = 6.0D0*H1 - 3.0D0*H2 + 0.5D0*H3 H1 = ZU(2) - P10 - P11 H2 = ZUV(2) - P11 - P12 = 3.0*H1 - H2 - P13 = -2.0*H1 + H2 - P21 = 0.5* (ZUU(2)-ZUU(1)) + P12 = 3.0D0*H1 - H2 + P13 = -2.0D0*H1 + H2 + P21 = 0.5D0* (ZUU(2)-ZUU(1)) END IF * Converts XII and YII to u-v system. DX = XII - X0 @@ -2166,9 +2314,9 @@ C WRITE (*,FMT=9040) P00 = Z0 P10 = PD(1,1) P01 = PD(2,1) - P20 = 0.5*PD(3,1) + P20 = 0.5D0*PD(3,1) P11 = PD(4,1) - P02 = 0.5*PD(5,1) + P02 = 0.5D0*PD(5,1) END IF * Converts XII and YII to U-V system. U = XII - X0 @@ -2219,13 +2367,13 @@ C WRITE (*,FMT=9040) * Converts the partial derivatives at the end points of the * border line segment for the u-v coordinate system. AA = A*A - ACT2 = 2.0*A*C + ACT2 = 2.0D0*A*C CC = C*C AB = A*B ADBC = AD + BC CD = C*D BB = B*B - BDT2 = 2.0*B*D + BDT2 = 2.0D0*B*D DD = D*D DO 100 I = 1,2 ZU(I) = A*PD(1,I) + C*PD(2,I) @@ -2238,20 +2386,20 @@ C WRITE (*,FMT=9040) P00 = Z(1) P10 = ZU(1) P01 = ZV(1) - P20 = 0.5*ZUU(1) + P20 = 0.5D0*ZUU(1) P11 = ZUV(1) - P02 = 0.5*ZVV(1) + P02 = 0.5D0*ZVV(1) H1 = Z(2) - P00 - P01 - P02 H2 = ZV(2) - P01 - ZVV(1) H3 = ZVV(2) - ZVV(1) - P03 = 10.0*H1 - 4.0*H2 + 0.5*H3 - P04 = -15.0*H1 + 7.0*H2 - H3 - P05 = 6.0*H1 - 3.0*H2 + 0.5*H3 + P03 = 10.0D0*H1 - 4.0D0*H2 + 0.5D0*H3 + P04 = -15.0D0*H1 + 7.0D0*H2 - H3 + P05 = 6.0D0*H1 - 3.0D0*H2 + 0.5D0*H3 H1 = ZU(2) - P10 - P11 H2 = ZUV(2) - P11 - P12 = 3.0*H1 - H2 - P13 = -2.0*H1 + H2 - P21 = 0.5* (ZUU(2)-ZUU(1)) + P12 = 3.0D0*H1 - H2 + P13 = -2.0D0*H1 + H2 + P21 = 0.5D0* (ZUU(2)-ZUU(1)) * Converts XII and YII to u-v system. DX = XII - X0 DY = YII - Y0 @@ -2277,6 +2425,643 @@ C WRITE (*,FMT=9040) END IF 120 CONTINUE END + SUBROUTINE ICOPY (N,IA1,IA2) + INTEGER N, IA1(N), IA2(N) +C +C*********************************************************** +C +C This subroutine copies integer array IA1 into array IA2. +C +C On input: +C +C N = Number of elements to be copied. No elements +C are copied if N < 1. +C +C IA1,IA2 = Source and destination, respectively, for +C the copy. The first N contiguously stored +C elements are copied regardless of the num- +C ber of dimensions of the arrays in the +C calling program. +C +C Parameters N and IA1 are not altered by this routine. +C +C On output: +C +C IA2 = Copy of IA1. +C +C Subprograms required by ICOPY: None +C +C*********************************************************** +C + INTEGER I +C + DO 1 I = 1,N + IA2(I) = IA1(I) + 1 CONTINUE + RETURN + END + SUBROUTINE GRADC(K,NCC,LCC,N,X,Y,Z,LIST,LPTR,LEND,DX,DY,DXX,DXY, + + DYY,IER) +* +************************************************************ +* +* From SRFPACK +* Robert J. Renka +* Dept. of Computer Science +* Univ. of North Texas +* (817) 565-2816 +* 01/25/97 +* +* Given a Delaunay triangulation of N points in the plane +* with associated data values Z, this subroutine estimates +* first and second partial derivatives at node K. The der- +* ivatives are taken to be the partials at K of a cubic +* function which interpolates Z(K) and fits the data values +* at a set of nearby nodes in a weighted least squares +* sense. A Marquardt stabilization factor is used if neces- +* sary to ensure a well-conditioned system. Thus, a unique +* solution exists if there are at least 10 noncollinear +* nodes. +* +* The triangulation may include constraints introduced by +* subroutine ADDCST, in which case the derivative estimates +* are influenced by the nonconvex geometry of the domain. +* Refer to subroutine GETNP. If data values at the con- +* straint nodes are not known, subroutine ZGRADL, which +* computes approximate data values at constraint nodes along +* with gradients, should be called in place of this routine. +* +* An alternative routine, GRADG, employs a global method +* to compute the first partial derivatives at all of the +* nodes at once. That method is usually more efficient +* (when all first partials are needed) and may be more ac- +* curate, depending on the data. +* +* On input: +* +* K = Index of the node at which derivatives are to be +* estimated. 1 .LE. K .LE. N. +* +* NCC = Number of constraint curves (refer to TRIPACK +* subroutine ADDCST). NCC .GE. 0. +* +* LCC = Array of length NCC (or dummy array of length +* 1 if NCC = 0) containing the index of the +* first node of constraint I in LCC(I). For I = +* 1 to NCC, LCC(I+1)-LCC(I) .GE. 3, where +* LCC(NCC+1) = N+1. +* +* N = Number of nodes in the triangulation. +* N .GE. 10. +* +* X,Y = Arrays of length N containing the coordinates +* of the nodes with non-constraint nodes in the +* first LCC(1)-1 locations, followed by NCC se- +* quences of constraint nodes. +* +* Z = Array of length N containing data values associ- +* ated with the nodes. +* +* LIST,LPTR,LEND = Data structure defining the trian- +* gulation. Refer to TRIPACK +* Subroutine TRMESH. +* +* Input parameters are not altered by this routine. +* +* On output: +* +* DX,DY = Estimated first partial derivatives at node +* K unless IER < 0. +* +* DXX,DXY,DYY = Estimated second partial derivatives +* at node K unless IER < 0. +* +* IER = Error indicator: +* IER = L > 0 if no errors were encountered and +* L nodes (including node K) were +* employed in the least squares fit. +* IER = -1 if K, NCC, an LCC entry, or N is +* outside its valid range on input. +* IER = -2 if all nodes are collinear. +* +* TRIPACK modules required by GRADC: GETNP, INTSEC +* +* SRFPACK modules required by GRADC: GIVENS, ROTATE, SETRO3 +* +* Intrinsic functions called by GRADC: DABS, MIN, DBLE, DSQRT +* +************************************************************ +* +* .. Parameters .. + INTEGER LMN,LMX + PARAMETER (LMN=14,LMX=30) +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION DX,DXX,DXY,DY,DYY + INTEGER IER,K,N,NCC +* .. +* .. Array Arguments .. + DOUBLE PRECISION X(N),Y(N),Z(N) + INTEGER LCC(*),LEND(N),LIST(*),LPTR(*) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C,DMIN,DS,DTOL,RIN,RS,RTOL,S,SF,SFC, + + SFS,STF,SUM,W,XK,YK,ZK + INTEGER I,IERR,J,JP1,KK,L,LM1,LMAX,LMIN,LNP,NP +* .. +* .. Local Arrays .. + DOUBLE PRECISION A(10,10),DIST(LMX) + INTEGER NPTS(LMX) +* .. +* .. External Subroutines .. + EXTERNAL GETNP,GIVENS,ROTATE,SETRO3 +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,MIN,DBLE,DSQRT +* .. +* .. Data statements .. + DATA RTOL/1.0D-5/,DTOL/0.01D0/ +* .. +* +* Local parameters: +* +* A = Transpose of the augmented regression matrix +* C = First component of the plane rotation deter- +* mined by subroutine GIVENS +* DIST = Array containing the distances between K and +* the elements of NPTS (refer to GETNP) +* DMIN = Minimum of the magnitudes of the diagonal +* elements of the regression matrix after +* zeros are introduced below the diagonal +* DS = Squared distance between nodes K and NPTS(LNP) +* DTOL = Tolerance for detecting an ill-conditioned +* system. The system is accepted when DMIN/W +* .GE. DTOL. +* I = DO-loop index +* IERR = Error flag for calls to GETNP +* J = DO-loop index +* JP1 = J+1 +* KK = Local copy of K +* L = Number of columns of A**T to which a rotation +* is applied +* LMAX,LMIN = Min(LMX,N), Min(LMN,N) +* LMN,LMX = Minimum and maximum values of LNP for N +* sufficiently large. In most cases LMN-1 +* nodes are used in the fit. 4 .LE. LMN .LE. +* LMX. +* LM1 = LMIN-1 or LNP-1 +* LNP = Length of NPTS +* NP = Element of NPTS to be added to the system +* NPTS = Array containing the indexes of a sequence of +* nodes ordered by distance from K. NPTS(1)=K +* and the first LNP-1 elements of NPTS are +* used in the least squares fit. Unless LNP +* exceeds LMAX, NPTS(LNP) determines R. +* RIN = Inverse of the distance R between node K and +* NPTS(LNP) or some point further from K than +* NPTS(LMAX) if NPTS(LMAX) is used in the fit. +* R is a radius of influence which enters into +* the weight W. +* RS = R*R +* RTOL = Tolerance for determining R. If the relative +* change in DS between two elements of NPTS is +* not greater than RTOL, they are treated as +* being the same distance from node K. +* S = Second component of the plane rotation deter- +* mined by subroutine GIVENS +* SF = Scale factor for the linear terms (columns 8 +* and 9) in the least squares fit -- inverse +* of the root-mean-square distance between K +* and the nodes (other than K) in the least +* squares fit +* SFS = Scale factor for the quadratic terms (columns +* 5, 6, and 7) in the least squares fit -- +* SF*SF +* SFC = Scale factor for the cubic terms (first 4 +* columns) in the least squares fit -- SF**3 +* STF = Marquardt stabilization factor used to damp +* out the first 4 solution components (third +* partials of the cubic) when the system is +* ill-conditioned. As STF increases, the +* fitting function approaches a quadratic +* polynomial. +* SUM = Sum of squared distances between node K and +* the nodes used in the least squares fit +* W = Weight associated with a row of the augmented +* regression matrix -- 1/D - 1/R, where D < R +* and D is the distance between K and a node +* entering into the least squares fit +* XK,YK,ZK = Coordinates and data value associated with K +* + KK = K +* +* Test for errors and initialize LMIN and LMAX. +* + IF (KK.LT.1 .OR. KK.GT.N .OR. NCC.LT.0 .OR. N.LT.10) GO TO 130 + LMIN = MIN(LMN,N) + LMAX = MIN(LMX,N) +* +* Compute NPTS, DIST, LNP, SF, SFS, SFC, and RIN -- +* +* Set NPTS to the closest LMIN-1 nodes to K. +* + SUM = 0.0D0 + NPTS(1) = KK + DIST(1) = 0.0D0 + LM1 = LMIN - 1 + DO 10 LNP = 2,LM1 + CALL GETNP(NCC,LCC,N,X,Y,LIST,LPTR,LEND,LNP,NPTS,DIST,IERR) + IF (IERR.NE.0) GO TO 130 + DS = DIST(LNP)**2 + SUM = SUM + DS + 10 CONTINUE +* +* Add additional nodes to NPTS until the relative increase +* in DS is at least RTOL. +* + DO 30 LNP = LMIN,LMAX + CALL GETNP(NCC,LCC,N,X,Y,LIST,LPTR,LEND,LNP,NPTS,DIST,IERR) + RS = DIST(LNP)**2 + IF ((RS-DS)/DS.LE.RTOL) GO TO 20 + IF (LNP.GT.10) GO TO 40 + 20 SUM = SUM + RS + 30 CONTINUE +* +* Use all LMAX nodes in the least squares fit. RS is +* arbitrarily increased by 10 per cent. +* + RS = 1.1D0*RS + LNP = LMAX + 1 +* +* There are LNP-2 equations corresponding to nodes NPTS(2), +* ...,NPTS(LNP-1). +* + 40 SFS = DBLE(LNP-2)/SUM + SF = DSQRT(SFS) + SFC = SF*SFS + RIN = 1.0D0/DSQRT(RS) + XK = X(KK) + YK = Y(KK) + ZK = Z(KK) +* +* A Q-R decomposition is used to solve the least squares +* system. The transpose of the augmented regression +* matrix is stored in A with columns (rows of A) defined +* as follows: 1-4 are the cubic terms, 5-7 are the quad- +* ratic terms with coefficients DXX/2, DXY, and DYY/2, +* 8 and 9 are the linear terms with coefficients DX and +* DY, and the last column is the right hand side. +* +* Set up the first 9 equations and zero out the lower tri- +* angle with Givens rotations. +* + DO 60 I = 1,9 + NP = NPTS(I+1) + W = 1.0D0/DIST(I+1) - RIN + CALL SETRO3(XK,YK,ZK,X(NP),Y(NP),Z(NP),SF,SFS,SFC,W,A(1,I)) + IF (I.EQ.1) GO TO 60 + DO 50 J = 1,I - 1 + JP1 = J + 1 + L = 10 - J + CALL GIVENS(A(J,J),A(J,I),C,S) + CALL ROTATE(L,C,S,A(JP1,J),A(JP1,I)) + 50 CONTINUE + 60 CONTINUE +* +* Add the additional equations to the system using +* the last column of A. I .LE. LNP. +* + I = 11 + 70 IF (I.LT.LNP) THEN + NP = NPTS(I) + W = 1.0D0/DIST(I) - RIN + CALL SETRO3(XK,YK,ZK,X(NP),Y(NP),Z(NP),SF,SFS,SFC,W,A(1,10)) + DO 80 J = 1,9 + JP1 = J + 1 + L = 10 - J + CALL GIVENS(A(J,J),A(J,10),C,S) + CALL ROTATE(L,C,S,A(JP1,J),A(JP1,10)) + 80 CONTINUE + I = I + 1 + GO TO 70 + END IF +* +* Test the system for ill-conditioning. +* + DMIN = MIN(DABS(A(1,1)),DABS(A(2,2)),DABS(A(3,3)),DABS(A(4,4)), + + DABS(A(5,5)),DABS(A(6,6)),DABS(A(7,7)),DABS(A(8,8)), + + DABS(A(9,9))) + IF (DMIN/W.GE.DTOL) GO TO 120 + IF (LNP.LE.LMAX) THEN +* +* Add another node to the system and increase R. Note +* that I = LNP. +* + LNP = LNP + 1 + IF (LNP.LE.LMAX) THEN + CALL GETNP(NCC,LCC,N,X,Y,LIST,LPTR,LEND,LNP,NPTS,DIST, + + IERR) + RS = DIST(LNP)**2 + END IF + RIN = 1.0D0/DSQRT(1.1D0*RS) + GO TO 70 + END IF +* +* Stabilize the system by damping third partials -- add +* multiples of the first four unit vectors to the first +* four equations. +* + STF = W + DO 110 I = 1,4 + A(I,10) = STF + DO 90 J = I + 1,10 + A(J,10) = 0.0D0 + 90 CONTINUE + DO 100 J = I,9 + JP1 = J + 1 + L = 10 - J + CALL GIVENS(A(J,J),A(J,10),C,S) + CALL ROTATE(L,C,S,A(JP1,J),A(JP1,10)) + 100 CONTINUE + 110 CONTINUE +* +* Test the damped system for ill-conditioning. +* + DMIN = MIN(DABS(A(5,5)),DABS(A(6,6)),DABS(A(7,7)),DABS(A(8,8)), + + DABS(A(9,9))) + IF (DMIN/W.LT.DTOL) GO TO 140 +* +* Solve the 9 by 9 triangular system for the last 5 +* components (first and second partial derivatives). +* + 120 DY = A(10,9)/A(9,9) + DX = (A(10,8)-A(9,8)*DY)/A(8,8) + DYY = (A(10,7)-A(8,7)*DX-A(9,7)*DY)/A(7,7) + DXY = (A(10,6)-A(7,6)*DYY-A(8,6)*DX-A(9,6)*DY)/A(6,6) + DXX = (A(10,5)-A(6,5)*DXY-A(7,5)*DYY-A(8,5)*DX-A(9,5)*DY)/A(5,5) +* +* Scale the solution components. +* + DX = SF*DX + DY = SF*DY + DXX = 2.*SFS*DXX + DXY = SFS*DXY + DYY = 2.*SFS*DYY + IER = LNP - 1 + RETURN +* +* Invalid input parameter. +* + 130 IER = -1 + RETURN +* +* No unique solution due to collinear nodes. +* + 140 IER = -2 + RETURN + END + SUBROUTINE GIVENS(A,B,C,S) +* +************************************************************ +* +* From SRFPACK +* Robert J. Renka +* Dept. of Computer Science +* Univ. of North Texas +* (817) 565-2767 +* 09/01/88 +* +* This subroutine constructs the Givens plane rotation, +* +* ( C S) +* G = ( ) , where C*C + S*S = 1, +* (-S C) +* +* which zeros the second component of the vector (A,B)**T +* (transposed). Subroutine ROTATE may be called to apply +* the transformation to a 2 by N matrix. +* +* This routine is identical to subroutine SROTG from the +* LINPACK BLAS (Basic Linear Algebra Subroutines). +* +* On input: +* +* A,B = Components of the vector defining the rota- +* tion. These are overwritten by values R +* and Z (described below) which define C and S. +* +* On output: +* +* A = Signed Euclidean norm R of the input vector: +* R = +/-SQRT(A*A + B*B) +* +* B = Value Z such that: +* C = SQRT(1-Z*Z) and S=Z if ABS(Z) .LE. 1, and +* C = 1/Z and S = SQRT(1-C*C) if ABS(Z) > 1. +* +* C = +/-(A/R) or 1 if R = 0. +* +* S = +/-(B/R) or 0 if R = 0. +* +* Modules required by GIVENS: None +* +* Intrinsic functions called by GIVENS: DABS, SQRT +* +************************************************************ +* +* +* Local parameters: +* +* AA,BB = Local copies of A and B +* R = C*A + S*B = +/-SQRT(A*A+B*B) +* U,V = Variables used to scale A and B for computing R +* +* .. Scalar Arguments .. + DOUBLE PRECISION A,B,C,S +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA,BB,R,U,V +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,DSQRT +* .. + AA = A + BB = B + IF (DABS(AA).LE.DABS(BB)) GO TO 10 +* +* ABS(A) > ABS(B). +* + U = AA + AA + V = BB/U + R = DSQRT(.25+V*V)*U + C = AA/R + S = V* (C+C) +* +* Note that R has the sign of A, C > 0, and S has +* SIGN(A)*SIGN(B). +* + B = S + A = R + RETURN +* +* ABS(A) .LE. ABS(B). +* + 10 IF (BB.EQ.0.0D0) GO TO 20 + U = BB + BB + V = AA/U +* +* Store R in A. +* + A = DSQRT(.25+V*V)*U + S = BB/A + C = V* (S+S) +* +* Note that R has the sign of B, S > 0, and C has +* SIGN(A)*SIGN(B). +* + B = 1.0D0 + IF (C.NE.0.0D0) B = 1.0D0/C + RETURN +* +* A = B = 0.0D0 +* + 20 C = 1.0D0 + S = 0.0D0 + RETURN + END + SUBROUTINE ROTATE(N,C,S,X,Y) +* +************************************************************ +* +* From SRFPACK +* Robert J. Renka +* Dept. of Computer Science +* Univ. of North Texas +* (817) 565-2767 +* 09/01/88 +* +* ( C S) +* This subroutine applies the Givens rotation ( ) to +* (-S C) +* (X(1) ... X(N)) +* the 2 by N matrix ( ) . +* (Y(1) ... Y(N)) +* +* This routine is identical to subroutine SROT from the +* LINPACK BLAS (Basic Linear Algebra Subroutines). +* +* On input: +* +* N = Number of columns to be rotated. +* +* C,S = Elements of the Givens rotation. Refer to +* subroutine GIVENS. +* +* The above parameters are not altered by this routine. +* +* X,Y = Arrays of length .GE. N containing the compo- +* nents of the vectors to be rotated. +* +* On output: +* +* X,Y = Arrays containing the rotated vectors (not +* altered if N < 1). +* +* Modules required by ROTATE: None +* +************************************************************ +* +* +* .. Scalar Arguments .. + DOUBLE PRECISION C,S + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION X(N),Y(N) +* .. +* .. Local Scalars .. + DOUBLE PRECISION XI,YI + INTEGER I +* .. + DO 10 I = 1,N + XI = X(I) + YI = Y(I) + X(I) = C*XI + S*YI + Y(I) = -S*XI + C*YI + 10 CONTINUE + RETURN + END + SUBROUTINE SETRO3(XK,YK,ZK,XI,YI,ZI,S1,S2,S3,W,ROW) +* +************************************************************ +* +* From SRFPACK +* Robert J. Renka +* Dept. of Computer Science +* Univ. of North Texas +* (817) 565-2767 +* 01/25/97 +* +* This subroutine sets up the I-th row of an augmented re- +* gression matrix for a weighted least squares fit of a +* cubic function f(x,y) to a set of data values z, where +* f(XK,YK) = ZK. The first four columns (cubic terms) are +* scaled by S3, the next three columns (quadratic terms) +* are scaled by S2, and the eighth and ninth columns (lin- +* ear terms) are scaled by S1. +* +* On input: +* +* XK,YK = Coordinates of node K. +* +* ZK = Data value at node K to be interpolated by f. +* +* XI,YI,ZI = Coordinates and data value at node I. +* +* S1,S2,S3 = Scale factors. +* +* W = Weight associated with node I. +* +* The above parameters are not altered by this routine. +* +* ROW = Array of length 10. +* +* On output: +* +* ROW = Array containing a row of the augmented re- +* gression matrix. +* +* Modules required by SETRO3: None +* +************************************************************ +* +* +* .. Scalar Arguments .. + DOUBLE PRECISION S1,S2,S3,W,XI,XK,YI,YK,ZI,ZK +* .. +* .. Array Arguments .. + DOUBLE PRECISION ROW(10) +* .. +* .. Local Scalars .. + DOUBLE PRECISION DX,DY,W1,W2,W3 +* .. + DX = XI - XK + DY = YI - YK + W1 = S1*W + W2 = S2*W + W3 = S3*W + ROW(1) = DX*DX*DX*W3 + ROW(2) = DX*DX*DY*W3 + ROW(3) = DX*DY*DY*W3 + ROW(4) = DY*DY*DY*W3 + ROW(5) = DX*DX*W2 + ROW(6) = DX*DY*W2 + ROW(7) = DY*DY*W2 + ROW(8) = DX*W1 + ROW(9) = DY*W1 + ROW(10) = (ZI-ZK)*W + RETURN + END * agebhard: add a linear interpolator, along the lines of sdplnl @@ -2351,7 +3136,7 @@ C WRITE (*,FMT=9040) + ZUV(3),ZV(3),ZVV(3) * .. * .. Intrinsic Functions .. - INTRINSIC MOD + INTRINSIC DABS,MOD * .. * Outermost DO-loop with respect to the output point DO 121 IIP = 1,NIP diff --git a/src/bilinear.f b/src/bilinear.f index 6de14550833e420285ddcbc2bac8a20ecee63644..43e422e0c08ca2d9f695bffd776e1da0d66618ec 100755 --- a/src/bilinear.f +++ b/src/bilinear.f @@ -1,14 +1,25 @@ - SUBROUTINE BILIIP(X0,Y0,Z0,N0,X,Y,Z,NX,NY) + SUBROUTINE BILIIP(X0,Y0,Z0,N0,X,Y,Z,NX,NY,IER) -C A. Gebhardt +C A. Gebhardt , Dec. 2016 +C +C Please note that this file is not associated with Akimas +C interpolation code (and so not under ACM license, so it can be +C reused without restriction), it is included here just for +C comparison with Akimas ACM 760 algorithm for regular gridded +C data. +C +C It implements bilinear (in contrast to bicubic as in ACM 760) +C interpolation, resulting in a continious but not differentiable +C (at grid lines) surface. IMPLICIT NONE - INTEGER NX,NY,N0 + INTEGER NX,NY,N0,IER DOUBLE PRECISION X0(*),Y0(*),Z0(*),X(*),Y(*),Z(NX,*) DOUBLE PRECISION XT,YT,X1,Y1 INTEGER K,I,J + IER=0 DO 10 K=1,N0 DO 20 I=1,NX-1 DO 30 J=1,NY-1 @@ -16,6 +27,10 @@ C A. Gebhardt IF ((Y(J).LE.Y0(K)).AND.(Y0(K).LE.Y(J+1))) THEN X1=X(I+1)-X(I) Y1=Y(J+1)-Y(J) + IF ((X1.EQ.0.0D0).OR.(Y1.EQ.0.0D0)) THEN + IER=1 + RETURN + ENDIF XT=(X0(K)-X(I))/X1 YT=(Y0(K)-Y(J))/Y1 Z0(K)=(1.0D0-YT)*(1.0D0-XT)*Z(I,J)+ diff --git a/src/idbvip.f b/src/idbvip.f deleted file mode 100644 index 385ae650834b610c958f3eee0647e05e2e0ea0e3..0000000000000000000000000000000000000000 --- a/src/idbvip.f +++ /dev/null @@ -1,148 +0,0 @@ - - SUBROUTINE IDBVIP(MD,NCP,NDP,XD,YD,ZD,NIP,XI,YI,ZI, ID001340 - 1 IWK,WK,MISSI) -C THIS SUBROUTINE PERFORMS BIVARIATE INTERPOLATION WHEN THE PRO- -C JECTIONS OF THE DATA POINTS IN THE X-Y PLANE ARE IRREGULARLY -C DISTRIBUTED IN THE PLANE. -C THE INPUT PARAMETERS ARE -C MD = MODE OF COMPUTATION (MUST BE 1, 2, OR 3), -C = 1 FOR NEW NCP AND/OR NEW XD-YD, -C = 2 FOR OLD NCP, OLD XD-YD, NEW XI-YI, -C = 3 FOR OLD NCP, OLD XD-YD, OLD XI-YI, -C NCP = NUMBER OF ADDITIONAL DATA POINTS USED FOR ESTI- -C MATING PARTIAL DERIVATIVES AT EACH DATA POINT -C (MUST BE 2 OR GREATER, BUT SMALLER THAN NDP), -C NDP = NUMBER OF DATA POINTS (MUST BE 4 OR GREATER), -C XD = ARRAY OF DIMENSION NDP CONTAINING THE X -C COORDINATES OF THE DATA POINTS, -C YD = ARRAY OF DIMENSION NDP CONTAINING THE Y -C COORDINATES OF THE DATA POINTS, -C ZD = ARRAY OF DIMENSION NDP CONTAINING THE Z -C COORDINATES OF THE DATA POINTS, -C NIP = NUMBER OF OUTPUT POINTS AT WHICH INTERPOLATION -C IS TO BE PERFORMED (MUST BE 1 OR GREATER), -C XI = ARRAY OF DIMENSION NIP CONTAINING THE X -C COORDINATES OF THE OUTPUT POINTS, -C YI = ARRAY OF DIMENSION NIP CONTAINING THE Y -C COORDINATES OF THE OUTPUT POINTS. -C THE OUTPUT PARAMETER IS -C ZI = ARRAY OF DIMENSION NIP WHERE INTERPOLATED Z -C VALUES ARE TO BE STORED. -C MISSI = LOCICAL ARRAY, INDICATING IF EXTRAPOLATION OR MISSING VALUES -C OUTSIDE CONVEX HULL WANTED -C THE OTHER PARAMETERS ARE -C IWK = INTEGER ARRAY OF DIMENSION -C MAX0(31,27+NCP)*NDP+NIP -C USED INTERNALLY AS A WORK AREA, -C WK = ARRAY OF DIMENSION 8*NDP USED INTERNALLY AS A -C WORK AREA. -C THE VERY FIRST CALL TO THIS SUBROUTINE AND THE CALL WITH A NEW -C NCP VALUE, A NEW NDP VALUE, AND/OR NEW CONTENTS OF THE XD AND -C YD ARRAYS MUST BE MADE WITH MD=1. THE CALL WITH MD=2 MUST BE -C PRECEDED BY ANOTHER CALL WITH THE SAME NCP AND NDP VALUES AND -C WITH THE SAME CONTENTS OF THE XD AND YD ARRAYS. THE CALL WITH -C MD=3 MUST BE PRECEDED BY ANOTHER CALL WITH THE SAME NCP, NDP, -C AND NIP VALUES AND WITH THE SAME CONTENTS OF THE XD, YD, XI, -C AND YI ARRAYS. BETWEEN THE CALL WITH MD=2 OR MD=3 AND ITS -C PRECEDING CALL, THE IWK AND WK ARRAYS MUST NOT BE DISTURBED. -C USE OF A VALUE BETWEEN 3 AND 5 (INCLUSIVE) FOR NCP IS RECOM- -C MENDED UNLESS THERE ARE EVIDENCES THAT DICTATE OTHERWISE. -C THE LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE -C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, -C THEREFORE, SYSTEM DEPENDENT. -C THIS SUBROUTINE CALLS THE IDCLDP, IDLCTN, IDPDRV, IDPTIP, AND -C IDTANG SUBROUTINES. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - LOGICAL MISSI, LINEAR - DIMENSION XD(NDP),YD(NDP),ZD(NDP),XI(NIP),YI(NIP), - 1 ZI(NIP),MISSI(NIP),IWK((31+NCP)*NDP+NIP),WK(8*NDP) - COMMON/IDLC/NIT, idummy - COMMON/IDPI/ITPV - DATA LUN/6/ -C SETTING OF SOME INPUT PARAMETERS TO LOCAL VARIABLES. -C (FOR MD=1,2,3) - 10 MD0=MD - NCP0=NCP - NDP0=NDP - NIP0=NIP -C ERROR CHECK. (FOR MD=1,2,3) - 20 IF(MD0.LT.1.OR.MD0.GT.3) GO TO 90 - IF(NCP0.EQ.0) THEN - LINEAR=.TRUE. - DO 21 I=1,NIP - MISSI(I)=.TRUE. - 21 CONTINUE - END IF - IF(NCP0.EQ.1.OR.NCP0.GE.NDP0) GO TO 90 - IF(NDP0.LT.4) GO TO 90 - IF(NIP0.LT.1) GO TO 90 - IF(MD0.GE.2) GO TO 22 - IWK(1)=NCP0 - IWK(2)=NDP0 - GO TO 23 - 22 NCPPV=IWK(1) - NDPPV=IWK(2) - IF(NCP0.NE.NCPPV) GO TO 90 - IF(NDP0.NE.NDPPV) GO TO 90 - 23 IF(MD0.GE.3) GO TO 24 - IWK(3)=NIP - GO TO 30 - 24 NIPPV=IWK(3) - IF(NIP0.NE.NIPPV) GO TO 90 -C ALLOCATION OF STORAGE AREAS IN THE IWK ARRAY. (FOR MD=1,2,3) - 30 JWIPT=16 - JWIWL=6*NDP0+1 - JWIWK=JWIWL - JWIPL=24*NDP0+1 - JWIWP=30*NDP0+1 - JWIPC=27*NDP0+1 - JWIT0=MAX0(31,27+NCP0)*NDP0 -C TRIANGULATES THE X-Y PLANE. (FOR MD=1) - 40 IF(MD0.GT.1) GO TO 50 - CALL IDTANG(NDP0,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL), - 1 IWK(JWIWL),IWK(JWIWP),WK) - IWK(5)=NT - IWK(6)=NL - IF(NT.EQ.0) RETURN -C DETERMINES NCP POINTS CLOSEST TO EACH DATA POINT. (FOR MD=1) - 50 IF(MD0.GT.1 .OR. LINEAR) GO TO 60 - CALL IDCLDP(NDP0,XD,YD,NCP0,IWK(JWIPC)) - IF(IWK(JWIPC).EQ.0) RETURN -C LOCATES ALL POINTS AT WHICH INTERPOLATION IS TO BE PERFORMED. -C (FOR MD=1,2) - 60 IF(MD0.EQ.3) GO TO 70 - NIT=0 - JWIT=JWIT0 - DO 61 IIP=1,NIP0 - JWIT=JWIT+1 - CALL IDLCTN(NDP0,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL), - 1 XI(IIP),YI(IIP),IWK(JWIT),IWK(JWIWK),WK) - 61 CONTINUE -C ESTIMATES PARTIAL DERIVATIVES AT ALL DATA POINTS. -C (FOR MD=1,2,3) - 70 IF (.NOT.LINEAR) CALL IDPDRV(NDP0,XD,YD,ZD,NCP0,IWK(JWIPC),WK) -C INTERPOLATES THE ZI VALUES. (FOR MD=1,2,3) - 80 ITPV=0 - JWIT=JWIT0 - DO 81 IIP=1,NIP0 - JWIT=JWIT+1 - IF (LINEAR) THEN - CALL IDPTLI(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL), - 1 IWK(JWIT),XI(IIP),YI(IIP),ZI(IIP),MISSI(IIP)) - ELSE - CALL IDPTIP(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),WK, - 1 IWK(JWIT),XI(IIP),YI(IIP),ZI(IIP),MISSI(IIP)) - END IF - 81 CONTINUE - RETURN -C ERROR EXIT - 90 CONTINUE -C WRITE (LUN,2090) MD0,NCP0,NDP0,NIP0 - RETURN -C FORMAT STATEMENT FOR ERROR MESSAGE - 2090 FORMAT(1X/41H *** IMPROPER INPUT PARAMETER VALUE(S)./ - 1 7H MD =,I4,10X,5HNCP =,I6,10X,5HNDP =,I6, - 2 10X,5HNIP =,I6/ - 3 35H ERROR DETECTED IN ROUTINE IDBVIP/) - END diff --git a/src/idcldp.f b/src/idcldp.f deleted file mode 100644 index ceda92c4e726e833aaf3a95013848002a94a7226..0000000000000000000000000000000000000000 --- a/src/idcldp.f +++ /dev/null @@ -1,118 +0,0 @@ - - SUBROUTINE IDCLDP(NDP,XD,YD,NCP,IPC) ID002720 -C THIS SUBROUTINE SELECTS SEVERAL DATA POINTS THAT ARE CLOSEST -C TO EACH OF THE DATA POINT. -C THE INPUT PARAMETERS ARE -C NDP = NUMBER OF DATA POINTS, -C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y -C COORDINATES OF THE DATA POINTS, -C NCP = NUMBER OF DATA POINTS CLOSEST TO EACH DATA -C POINTS. -C THE OUTPUT PARAMETER IS -C IPC = INTEGER ARRAY OF DIMENSION NCP*NDP, WHERE THE -C POINT NUMBERS OF NCP DATA POINTS CLOSEST TO -C EACH OF THE NDP DATA POINTS ARE TO BE STORED. -C THIS SUBROUTINE ARBITRARILY SETS A RESTRICTION THAT NCP MUST -C NOT EXCEED 25. -C THE LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE -C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, -C THEREFORE, SYSTEM DEPENDENT. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - DIMENSION XD(NDP),YD(NDP),IPC(NCP*NDP) - DIMENSION DSQ0(25),IPC0(25) - DATA NCPMX/25/, LUN/6/ -C STATEMENT FUNCTION - DSQF(U1,V1,U2,V2)=(U2-U1)**2+(V2-V1)**2 -C PRELIMINARY PROCESSING - 10 NDP0=NDP - NCP0=NCP - IF(NDP0.LT.2) GO TO 90 - IF(NCP0.LT.1.OR.NCP0.GT.NCPMX.OR.NCP0.GE.NDP0) GO TO 90 -C CALCULATION - 20 DO 59 IP1=1,NDP0 -C - SELECTS NCP POINTS. - X1=XD(IP1) - Y1=YD(IP1) - J1=0 - DSQMX=0.0 - DO 22 IP2=1,NDP0 - IF(IP2.EQ.IP1) GO TO 22 - DSQI=DSQF(X1,Y1,XD(IP2),YD(IP2)) - J1=J1+1 - DSQ0(J1)=DSQI - IPC0(J1)=IP2 - IF(DSQI.LE.DSQMX) GO TO 21 - DSQMX=DSQI - JMX=J1 - 21 IF(J1.GE.NCP0) GO TO 23 - 22 CONTINUE - 23 IP2MN=IP2+1 - IF(IP2MN.GT.NDP0) GO TO 30 - DO 25 IP2=IP2MN,NDP0 - IF(IP2.EQ.IP1) GO TO 25 - DSQI=DSQF(X1,Y1,XD(IP2),YD(IP2)) - IF(DSQI.GE.DSQMX) GO TO 25 - DSQ0(JMX)=DSQI - IPC0(JMX)=IP2 - DSQMX=0.0 - DO 24 J1=1,NCP0 - IF(DSQ0(J1).LE.DSQMX) GO TO 24 - DSQMX=DSQ0(J1) - JMX=J1 - 24 CONTINUE - 25 CONTINUE -C - CHECKS IF ALL THE NCP+1 POINTS ARE COLLINEAR. - 30 IP2=IPC0(1) - DX12=XD(IP2)-X1 - DY12=YD(IP2)-Y1 - DO 31 J3=2,NCP0 - IP3=IPC0(J3) - DX13=XD(IP3)-X1 - DY13=YD(IP3)-Y1 - IF((DY13*DX12-DX13*DY12).NE.0.0) GO TO 50 - 31 CONTINUE -C - SEARCHES FOR THE CLOSEST NONCOLLINEAR POINT. - 40 NCLPT=0 - DO 43 IP3=1,NDP0 - IF(IP3.EQ.IP1) GO TO 43 - DO 41 J4=1,NCP0 - IF(IP3.EQ.IPC0(J4)) GO TO 43 - 41 CONTINUE - DX13=XD(IP3)-X1 - DY13=YD(IP3)-Y1 - IF((DY13*DX12-DX13*DY12).EQ.0.0) GO TO 43 - DSQI=DSQF(X1,Y1,XD(IP3),YD(IP3)) - IF(NCLPT.EQ.0) GO TO 42 - IF(DSQI.GE.DSQMN) GO TO 43 - 42 NCLPT=1 - DSQMN=DSQI - IP3MN=IP3 - 43 CONTINUE - IF(NCLPT.EQ.0) GO TO 91 - DSQMX=DSQMN - IPC0(JMX)=IP3MN -C - REPLACES THE LOCAL ARRAY FOR THE OUTPUT ARRAY. - 50 J1=(IP1-1)*NCP0 - DO 51 J2=1,NCP0 - J1=J1+1 - IPC(J1)=IPC0(J2) - 51 CONTINUE - 59 CONTINUE - RETURN -C ERROR EXIT - 90 CONTINUE -C WRITE (LUN,2090) - GO TO 92 - 91 CONTINUE -C WRITE (LUN,2091) - 92 CONTINUE -C WRITE (LUN,2092) NDP0,NCP0 - IPC(1)=0 - RETURN -C FORMAT STATEMENTS FOR ERROR MESSAGES - 2090 FORMAT(1X/41H *** IMPROPER INPUT PARAMETER VALUE(S).) - 2091 FORMAT(1X/33H *** ALL COLLINEAR DATA POINTS.) - 2092 FORMAT(8H NDP =,I5,5X,5HNCP =,I5/ - 1 35H ERROR DETECTED IN ROUTINE IDCLDP/) - END diff --git a/src/idgrid.f b/src/idgrid.f deleted file mode 100644 index 1dcd3c0bdca957e8bb82ebc4a7e449adf690e588..0000000000000000000000000000000000000000 --- a/src/idgrid.f +++ /dev/null @@ -1,238 +0,0 @@ - - SUBROUTINE IDGRID(XD, YD, NDP, NT, IPT, NL, IPL, NXI, NYI, XI, YI, IDG 10 - * NGP, IGP) -C THIS SUBROUTINE ORGANIZES GRID POINTS FOR SURFACE FITTING BY -C SORTING THEM IN ASCENDING ORDER OF TRIANGLE NUMBERS AND OF THE -C BORDER LINE SEGMENT NUMBER. -C THE INPUT PARAMETERS ARE -C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y -C COORDINATES OF THE DATA POINTS, WHERE NDP IS THE -C NUMBER OF THE DATA POINTS, -C NT = NUMBER OF TRIANGLES, -C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE -C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, -C NL = NUMBER OF BORDER LINE SEGMENTS, -C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE -C POINT NUMBERS OF THE END POINTS OF THE BORDER -C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE -C NUMBERS, -C NXI = NUMBER OF GRID POINTS IN THE X COORDINATE, -C NYI = NUMBER OF GRID POINTS IN THE Y COORDINATE, -C XI,YI = ARRAYS OF DIMENSION NXI AND NYI CONTAINING -C THE X AND Y COORDINATES OF THE GRID POINTS, -C RESPECTIVELY. -C THE OUTPUT PARAMETERS ARE -C NGP = INTEGER ARRAY OF DIMENSION 2*(NT+2*NL) WHERE THE -C NUMBER OF GRID POINTS THAT BELONG TO EACH OF THE -C TRIANGLES OR OF THE BORDER LINE SEGMENTS ARE TO -C BE STORED, -C IGP = INTEGER ARRAY OF DIMENSION NXI*NYI WHERE THE -C GRID POINT NUMBERS ARE TO BE STORED IN ASCENDING -C ORDER OF THE TRIANGLE NUMBER AND THE BORDER LINE -C SEGMENT NUMBER. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - DIMENSION XD(NDP), YD(NDP), IPT(3*NT), IPL(3*NL), XI(NXI), - * YI(NYI), NGP(2*(NT+2*NL)), IGP(NXI*NYI) -C STATEMENT FUNCTIONS - SIDE(U1,V1,U2,V2,U3,V3) = (U1-U3)*(V2-V3) - (V1-V3)*(U2-U3) - SPDT(U1,V1,U2,V2,U3,V3) = (U1-U2)*(U3-U2) + (V1-V2)*(V3-V2) -C PRELIMINARY PROCESSING - NT0 = NT - NL0 = NL - NXI0 = NXI - NYI0 = NYI - NXINYI = NXI0*NYI0 - XIMN = DMIN1(XI(1),XI(NXI0)) - XIMX = DMAX1(XI(1),XI(NXI0)) - YIMN = DMIN1(YI(1),YI(NYI0)) - YIMX = DMAX1(YI(1),YI(NYI0)) -C DETERMINES GRID POINTS INSIDE THE DATA AREA. - JNGP0 = 0 - JNGP1 = 2*(NT0+2*NL0) + 1 - JIGP0 = 0 - JIGP1 = NXINYI + 1 - DO 160 IT0=1,NT0 - NGP0 = 0 - NGP1 = 0 - IT0T3 = IT0*3 - IP1 = IPT(IT0T3-2) - IP2 = IPT(IT0T3-1) - IP3 = IPT(IT0T3) - X1 = XD(IP1) - Y1 = YD(IP1) - X2 = XD(IP2) - Y2 = YD(IP2) - X3 = XD(IP3) - Y3 = YD(IP3) - XMN = DMIN1(X1,X2,X3) - XMX = DMAX1(X1,X2,X3) - YMN = DMIN1(Y1,Y2,Y3) - YMX = DMAX1(Y1,Y2,Y3) - INSD = 0 - DO 20 IXI=1,NXI0 - IF (XI(IXI).GE.XMN .AND. XI(IXI).LE.XMX) GO TO 10 - IF (INSD.EQ.0) GO TO 20 - IXIMX = IXI - 1 - GO TO 30 - 10 IF (INSD.EQ.1) GO TO 20 - INSD = 1 - IXIMN = IXI - 20 CONTINUE - IF (INSD.EQ.0) GO TO 150 - IXIMX = NXI0 - 30 DO 140 IYI=1,NYI0 - YII = YI(IYI) - IF (YII.LT.YMN .OR. YII.GT.YMX) GO TO 140 - DO 130 IXI=IXIMN,IXIMX - XII = XI(IXI) - L = 0 - IF (SIDE(X1,Y1,X2,Y2,XII,YII)) 130, 40, 50 - 40 L = 1 - 50 IF (SIDE(X2,Y2,X3,Y3,XII,YII)) 130, 60, 70 - 60 L = 1 - 70 IF (SIDE(X3,Y3,X1,Y1,XII,YII)) 130, 80, 90 - 80 L = 1 - 90 IZI = NXI0*(IYI-1) + IXI - IF (L.EQ.1) GO TO 100 - NGP0 = NGP0 + 1 - JIGP0 = JIGP0 + 1 - IGP(JIGP0) = IZI - GO TO 130 - 100 IF (JIGP1.GT.NXINYI) GO TO 120 - DO 110 JIGP1I=JIGP1,NXINYI - IF (IZI.EQ.IGP(JIGP1I)) GO TO 130 - 110 CONTINUE - 120 NGP1 = NGP1 + 1 - JIGP1 = JIGP1 - 1 - IGP(JIGP1) = IZI - 130 CONTINUE - 140 CONTINUE - 150 JNGP0 = JNGP0 + 1 - NGP(JNGP0) = NGP0 - JNGP1 = JNGP1 - 1 - NGP(JNGP1) = NGP1 - 160 CONTINUE -C DETERMINES GRID POINTS OUTSIDE THE DATA AREA. -C - IN SEMI-INFINITE RECTANGULAR AREA. - DO 450 IL0=1,NL0 - NGP0 = 0 - NGP1 = 0 - IL0T3 = IL0*3 - IP1 = IPL(IL0T3-2) - IP2 = IPL(IL0T3-1) - X1 = XD(IP1) - Y1 = YD(IP1) - X2 = XD(IP2) - Y2 = YD(IP2) - XMN = XIMN - XMX = XIMX - YMN = YIMN - YMX = YIMX - IF (Y2.GE.Y1) XMN = DMIN1(X1,X2) - IF (Y2.LE.Y1) XMX = DMAX1(X1,X2) - IF (X2.LE.X1) YMN = DMIN1(Y1,Y2) - IF (X2.GE.X1) YMX = DMAX1(Y1,Y2) - INSD = 0 - DO 180 IXI=1,NXI0 - IF (XI(IXI).GE.XMN .AND. XI(IXI).LE.XMX) GO TO 170 - IF (INSD.EQ.0) GO TO 180 - IXIMX = IXI - 1 - GO TO 190 - 170 IF (INSD.EQ.1) GO TO 180 - INSD = 1 - IXIMN = IXI - 180 CONTINUE - IF (INSD.EQ.0) GO TO 310 - IXIMX = NXI0 - 190 DO 300 IYI=1,NYI0 - YII = YI(IYI) - IF (YII.LT.YMN .OR. YII.GT.YMX) GO TO 300 - DO 290 IXI=IXIMN,IXIMX - XII = XI(IXI) - L = 0 - IF (SIDE(X1,Y1,X2,Y2,XII,YII)) 210, 200, 290 - 200 L = 1 - 210 IF (SPDT(X2,Y2,X1,Y1,XII,YII)) 290, 220, 230 - 220 L = 1 - 230 IF (SPDT(X1,Y1,X2,Y2,XII,YII)) 290, 240, 250 - 240 L = 1 - 250 IZI = NXI0*(IYI-1) + IXI - IF (L.EQ.1) GO TO 260 - NGP0 = NGP0 + 1 - JIGP0 = JIGP0 + 1 - IGP(JIGP0) = IZI - GO TO 290 - 260 IF (JIGP1.GT.NXINYI) GO TO 280 - DO 270 JIGP1I=JIGP1,NXINYI - IF (IZI.EQ.IGP(JIGP1I)) GO TO 290 - 270 CONTINUE - 280 NGP1 = NGP1 + 1 - JIGP1 = JIGP1 - 1 - IGP(JIGP1) = IZI - 290 CONTINUE - 300 CONTINUE - 310 JNGP0 = JNGP0 + 1 - NGP(JNGP0) = NGP0 - JNGP1 = JNGP1 - 1 - NGP(JNGP1) = NGP1 -C - IN SEMI-INFINITE TRIANGULAR AREA. - NGP0 = 0 - NGP1 = 0 - ILP1 = MOD(IL0,NL0) + 1 - ILP1T3 = ILP1*3 - IP3 = IPL(ILP1T3-1) - X3 = XD(IP3) - Y3 = YD(IP3) - XMN = XIMN - XMX = XIMX - YMN = YIMN - YMX = YIMX - IF (Y3.GE.Y2 .AND. Y2.GE.Y1) XMN = X2 - IF (Y3.LE.Y2 .AND. Y2.LE.Y1) XMX = X2 - IF (X3.LE.X2 .AND. X2.LE.X1) YMN = Y2 - IF (X3.GE.X2 .AND. X2.GE.X1) YMX = Y2 - INSD = 0 - DO 330 IXI=1,NXI0 - IF (XI(IXI).GE.XMN .AND. XI(IXI).LE.XMX) GO TO 320 - IF (INSD.EQ.0) GO TO 330 - IXIMX = IXI - 1 - GO TO 340 - 320 IF (INSD.EQ.1) GO TO 330 - INSD = 1 - IXIMN = IXI - 330 CONTINUE - IF (INSD.EQ.0) GO TO 440 - IXIMX = NXI0 - 340 DO 430 IYI=1,NYI0 - YII = YI(IYI) - IF (YII.LT.YMN .OR. YII.GT.YMX) GO TO 430 - DO 420 IXI=IXIMN,IXIMX - XII = XI(IXI) - L = 0 - IF (SPDT(X1,Y1,X2,Y2,XII,YII)) 360, 350, 420 - 350 L = 1 - 360 IF (SPDT(X3,Y3,X2,Y2,XII,YII)) 380, 370, 420 - 370 L = 1 - 380 IZI = NXI0*(IYI-1) + IXI - IF (L.EQ.1) GO TO 390 - NGP0 = NGP0 + 1 - JIGP0 = JIGP0 + 1 - IGP(JIGP0) = IZI - GO TO 420 - 390 IF (JIGP1.GT.NXINYI) GO TO 410 - DO 400 JIGP1I=JIGP1,NXINYI - IF (IZI.EQ.IGP(JIGP1I)) GO TO 420 - 400 CONTINUE - 410 NGP1 = NGP1 + 1 - JIGP1 = JIGP1 - 1 - IGP(JIGP1) = IZI - 420 CONTINUE - 430 CONTINUE - 440 JNGP0 = JNGP0 + 1 - NGP(JNGP0) = NGP0 - JNGP1 = JNGP1 - 1 - NGP(JNGP1) = NGP1 - 450 CONTINUE - RETURN - END diff --git a/src/idlctn.f b/src/idlctn.f deleted file mode 100644 index e4e00899ed74a87fed32c9959443e418d0c370df..0000000000000000000000000000000000000000 --- a/src/idlctn.f +++ /dev/null @@ -1,221 +0,0 @@ - - SUBROUTINE IDLCTN(NDP, XD, YD, NT, IPT, NL, IPL, XII, YII, ITI, IDL 10 - * IWK, WK) -C THIS SUBROUTINE LOCATES A POINT, I.E., DETERMINES TO WHAT TRI- -C ANGLE A GIVEN POINT (XII,YII) BELONGS. WHEN THE GIVEN POINT -C DOES NOT LIE INSIDE THE DATA AREA, THIS SUBROUTINE DETERMINES -C THE BORDER LINE SEGMENT WHEN THE POINT LIES IN AN OUTSIDE -C RECTANGULAR AREA, AND TWO BORDER LINE SEGMENTS WHEN THE POINT -C LIES IN AN OUTSIDE TRIANGULAR AREA. -C THE INPUT PARAMETERS ARE -C NDP = NUMBER OF DATA POINTS, -C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y -C COORDINATES OF THE DATA POINTS, -C NT = NUMBER OF TRIANGLES, -C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE -C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, -C NL = NUMBER OF BORDER LINE SEGMENTS, -C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE -C POINT NUMBERS OF THE END POINTS OF THE BORDER -C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE -C NUMBERS, -C XII,YII = X AND Y COORDINATES OF THE POINT TO BE -C LOCATED. -C THE OUTPUT PARAMETER IS -C ITI = TRIANGLE NUMBER, WHEN THE POINT IS INSIDE THE -C DATA AREA, OR -C TWO BORDER LINE SEGMENT NUMBERS, IL1 AND IL2, -C CODED TO IL1*(NT+NL)+IL2, WHEN THE POINT IS -C OUTSIDE THE DATA AREA. -C THE OTHER PARAMETERS ARE -C IWK = INTEGER ARRAY OF DIMENSION 18*NDP USED INTER- -C NALLY AS A WORK AREA, -C WK = ARRAY OF DIMENSION 8*NDP USED INTERNALLY AS A -C WORK AREA. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - DIMENSION XD(NDP), YD(NDP), IPT(3*NT), IPL(3*NL), IWK(18*NDP), - * WK(8*NDP) - DIMENSION NTSC(9), IDSC(9) - COMMON /IDLC/ NIT, ITIPV -C agebhard@uni-klu.ac.at: -C Fix an error caused by uninitialized values on second call, -C possibly I added too much variables to this common block by guessing -C their names from beeing used between "GO TO 80" and line "80": - COMMON /IDLCT/ XMN,XMX,YMN,YMX,XI,YI,XS1,YS1,XS2,YS2,NTSC,IDSC, - * IT0T3,JWK,I1,I2,I3 -C STATEMENT FUNCTIONS - SIDE(U1,V1,U2,V2,U3,V3) = (U1-U3)*(V2-V3) - (V1-V3)*(U2-U3) - SPDT(U1,V1,U2,V2,U3,V3) = (U1-U2)*(U3-U2) + (V1-V2)*(V3-V2) -C PRELIMINARY PROCESSING - NDP0 = NDP - NT0 = NT - NL0 = NL - NTL = NT0 + NL0 - X0 = XII - Y0 = YII -C PROCESSING FOR A NEW SET OF DATA POINTS - IF (NIT.NE.0) GO TO 80 - NIT = 1 -C - DIVIDES THE X-Y PLANE INTO NINE RECTANGULAR SECTIONS. - XMN = XD(1) - XMX = XMN - YMN = YD(1) - YMX = YMN - DO 10 IDP=2,NDP0 - XI = XD(IDP) - YI = YD(IDP) - XMN = DMIN1(XI,XMN) - XMX = DMAX1(XI,XMX) - YMN = DMIN1(YI,YMN) - YMX = DMAX1(YI,YMX) - 10 CONTINUE - XS1 = (XMN+XMN+XMX)/3.0 - XS2 = (XMN+XMX+XMX)/3.0 - YS1 = (YMN+YMN+YMX)/3.0 - YS2 = (YMN+YMX+YMX)/3.0 -C - DETERMINES AND STORES IN THE IWK ARRAY TRIANGLE NUMBERS OF -C - THE TRIANGLES ASSOCIATED WITH EACH OF THE NINE SECTIONS. - DO 20 ISC=1,9 - NTSC(ISC) = 0 - IDSC(ISC) = 0 - 20 CONTINUE - IT0T3 = 0 - JWK = 0 - DO 70 IT0=1,NT0 - IT0T3 = IT0T3 + 3 - I1 = IPT(IT0T3-2) - I2 = IPT(IT0T3-1) - I3 = IPT(IT0T3) - XMN = DMIN1(XD(I1),XD(I2),XD(I3)) - XMX = DMAX1(XD(I1),XD(I2),XD(I3)) - YMN = DMIN1(YD(I1),YD(I2),YD(I3)) - YMX = DMAX1(YD(I1),YD(I2),YD(I3)) - IF (YMN.GT.YS1) GO TO 30 - IF (XMN.LE.XS1) IDSC(1) = 1 - IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(2) = 1 - IF (XMX.GE.XS2) IDSC(3) = 1 - 30 IF (YMX.LT.YS1 .OR. YMN.GT.YS2) GO TO 40 - IF (XMN.LE.XS1) IDSC(4) = 1 - IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(5) = 1 - IF (XMX.GE.XS2) IDSC(6) = 1 - 40 IF (YMX.LT.YS2) GO TO 50 - IF (XMN.LE.XS1) IDSC(7) = 1 - IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(8) = 1 - IF (XMX.GE.XS2) IDSC(9) = 1 - 50 DO 60 ISC=1,9 - IF (IDSC(ISC).EQ.0) GO TO 60 - JIWK = 9*NTSC(ISC) + ISC - IWK(JIWK) = IT0 - NTSC(ISC) = NTSC(ISC) + 1 - IDSC(ISC) = 0 - 60 CONTINUE -C - STORES IN THE WK ARRAY THE MINIMUM AND MAXIMUM OF THE X AND -C - Y COORDINATE VALUES FOR EACH OF THE TRIANGLE. - JWK = JWK + 4 - WK(JWK-3) = XMN - WK(JWK-2) = XMX - WK(JWK-1) = YMN - WK(JWK) = YMX - 70 CONTINUE - GO TO 110 -C CHECKS IF IN THE SAME TRIANGLE AS PREVIOUS. - 80 IT0 = ITIPV - IF (IT0.GT.NT0) GO TO 90 - IT0T3 = IT0*3 - IP1 = IPT(IT0T3-2) - X1 = XD(IP1) - Y1 = YD(IP1) - IP2 = IPT(IT0T3-1) - X2 = XD(IP2) - Y2 = YD(IP2) - IF (SIDE(X1,Y1,X2,Y2,X0,Y0).LT.0.0) GO TO 110 - IP3 = IPT(IT0T3) - X3 = XD(IP3) - Y3 = YD(IP3) - IF (SIDE(X2,Y2,X3,Y3,X0,Y0).LT.0.0) GO TO 110 - IF (SIDE(X3,Y3,X1,Y1,X0,Y0).LT.0.0) GO TO 110 - GO TO 170 -C CHECKS IF ON THE SAME BORDER LINE SEGMENT. - 90 IL1 = IT0/NTL - IL2 = IT0 - IL1*NTL - IL1T3 = IL1*3 - IP1 = IPL(IL1T3-2) - X1 = XD(IP1) - Y1 = YD(IP1) - IP2 = IPL(IL1T3-1) - X2 = XD(IP2) - Y2 = YD(IP2) - IF (IL2.NE.IL1) GO TO 100 - IF (SPDT(X1,Y1,X2,Y2,X0,Y0).LT.0.0) GO TO 110 - IF (SPDT(X2,Y2,X1,Y1,X0,Y0).LT.0.0) GO TO 110 - IF (SIDE(X1,Y1,X2,Y2,X0,Y0).GT.0.0) GO TO 110 - GO TO 170 -C CHECKS IF BETWEEN THE SAME TWO BORDER LINE SEGMENTS. - 100 IF (SPDT(X1,Y1,X2,Y2,X0,Y0).GT.0.0) GO TO 110 - IP3 = IPL(3*IL2-1) - X3 = XD(IP3) - Y3 = YD(IP3) - IF (SPDT(X3,Y3,X2,Y2,X0,Y0).LE.0.0) GO TO 170 -C LOCATES INSIDE THE DATA AREA. -C - DETERMINES THE SECTION IN WHICH THE POINT IN QUESTION LIES. - 110 ISC = 1 - IF (X0.GE.XS1) ISC = ISC + 1 - IF (X0.GE.XS2) ISC = ISC + 1 - IF (Y0.GE.YS1) ISC = ISC + 3 - IF (Y0.GE.YS2) ISC = ISC + 3 -C - SEARCHES THROUGH THE TRIANGLES ASSOCIATED WITH THE SECTION. - NTSCI = NTSC(ISC) - IF (NTSCI.LE.0) GO TO 130 - JIWK = -9 + ISC - DO 120 ITSC=1,NTSCI - JIWK = JIWK + 9 - IT0 = IWK(JIWK) - JWK = IT0*4 - IF (X0.LT.WK(JWK-3)) GO TO 120 - IF (X0.GT.WK(JWK-2)) GO TO 120 - IF (Y0.LT.WK(JWK-1)) GO TO 120 - IF (Y0.GT.WK(JWK)) GO TO 120 - IT0T3 = IT0*3 - IP1 = IPT(IT0T3-2) - X1 = XD(IP1) - Y1 = YD(IP1) - IP2 = IPT(IT0T3-1) - X2 = XD(IP2) - Y2 = YD(IP2) - IF (SIDE(X1,Y1,X2,Y2,X0,Y0).LT.0.0) GO TO 120 - IP3 = IPT(IT0T3) - X3 = XD(IP3) - Y3 = YD(IP3) - IF (SIDE(X2,Y2,X3,Y3,X0,Y0).LT.0.0) GO TO 120 - IF (SIDE(X3,Y3,X1,Y1,X0,Y0).LT.0.0) GO TO 120 - GO TO 170 - 120 CONTINUE -C LOCATES OUTSIDE THE DATA AREA. - 130 DO 150 IL1=1,NL0 - IL1T3 = IL1*3 - IP1 = IPL(IL1T3-2) - X1 = XD(IP1) - Y1 = YD(IP1) - IP2 = IPL(IL1T3-1) - X2 = XD(IP2) - Y2 = YD(IP2) - IF (SPDT(X2,Y2,X1,Y1,X0,Y0).LT.0.0) GO TO 150 - IF (SPDT(X1,Y1,X2,Y2,X0,Y0).LT.0.0) GO TO 140 - IF (SIDE(X1,Y1,X2,Y2,X0,Y0).GT.0.0) GO TO 150 - IL2 = IL1 - GO TO 160 - 140 IL2 = MOD(IL1,NL0) + 1 - IP3 = IPL(3*IL2-1) - X3 = XD(IP3) - Y3 = YD(IP3) - IF (SPDT(X3,Y3,X2,Y2,X0,Y0).LE.0.0) GO TO 160 - 150 CONTINUE - IT0 = 1 - GO TO 170 - 160 IT0 = IL1*NTL + IL2 -C NORMAL EXIT - 170 ITI = IT0 - ITIPV = IT0 - RETURN - END diff --git a/src/idpdrv.f b/src/idpdrv.f deleted file mode 100644 index 43cc2ebe02a5f570229b4e6d3c77aa26da9bf2ad..0000000000000000000000000000000000000000 --- a/src/idpdrv.f +++ /dev/null @@ -1,120 +0,0 @@ - - SUBROUTINE IDPDRV(NDP,XD,YD,ZD,NCP,IPC,PD) ID008940 -C THIS SUBROUTINE ESTIMATES PARTIAL DERIVATIVES OF THE FIRST AND -C SECOND ORDER AT THE DATA POINTS. -C THE INPUT PARAMETERS ARE -C NDP = NUMBER OF DATA POINTS, -C XD,YD,ZD = ARRAYS OF DIMENSION NDP CONTAINING THE X, -C Y, AND Z COORDINATES OF THE DATA POINTS, -C NCP = NUMBER OF ADDITIONAL DATA POINTS USED FOR ESTI- -C MATING PARTIAL DERIVATIVES AT EACH DATA POINT, -C IPC = INTEGER ARRAY OF DIMENSION NCP*NDP CONTAINING -C THE POINT NUMBERS OF NCP DATA POINTS CLOSEST TO -C EACH OF THE NDP DATA POINTS. -C THE OUTPUT PARAMETER IS -C PD = ARRAY OF DIMENSION 5*NDP, WHERE THE ESTIMATED -C ZX, ZY, ZXX, ZXY, AND ZYY VALUES AT THE DATA -C POINTS ARE TO BE STORED. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - DIMENSION XD(NDP),YD(NDP),ZD(NDP),IPC(NCP*NDP),PD(5*NDP) - DOUBLE PRECISION NMX,NMY,NMZ,NMXX,NMXY,NMYX,NMYY -C PRELIMINARY PROCESSING - 10 NDP0=NDP - NCP0=NCP - NCPM1=NCP0-1 -C ESTIMATION OF ZX AND ZY - 20 DO 24 IP0=1,NDP0 - X0=XD(IP0) - Y0=YD(IP0) - Z0=ZD(IP0) - NMX=0.0 - NMY=0.0 - NMZ=0.0 - JIPC0=NCP0*(IP0-1) - DO 23 IC1=1,NCPM1 - JIPC=JIPC0+IC1 - IPI=IPC(JIPC) - DX1=XD(IPI)-X0 - DY1=YD(IPI)-Y0 - DZ1=ZD(IPI)-Z0 - IC2MN=IC1+1 - DO 22 IC2=IC2MN,NCP0 - JIPC=JIPC0+IC2 - IPI=IPC(JIPC) - DX2=XD(IPI)-X0 - DY2=YD(IPI)-Y0 - DNMZ=DX1*DY2-DY1*DX2 - IF(DNMZ.EQ.0.0) GO TO 22 - DZ2=ZD(IPI)-Z0 - DNMX=DY1*DZ2-DZ1*DY2 - DNMY=DZ1*DX2-DX1*DZ2 - IF(DNMZ.GE.0.0) GO TO 21 - DNMX=-DNMX - DNMY=-DNMY - DNMZ=-DNMZ - 21 NMX=NMX+DNMX - NMY=NMY+DNMY - NMZ=NMZ+DNMZ - 22 CONTINUE - 23 CONTINUE - JPD0=5*IP0 - PD(JPD0-4)=-NMX/NMZ - PD(JPD0-3)=-NMY/NMZ - 24 CONTINUE -C ESTIMATION OF ZXX, ZXY, AND ZYY - 30 DO 34 IP0=1,NDP0 - JPD0=JPD0+5 - X0=XD(IP0) - JPD0=5*IP0 - Y0=YD(IP0) - ZX0=PD(JPD0-4) - ZY0=PD(JPD0-3) - NMXX=0.0 - NMXY=0.0 - NMYX=0.0 - NMYY=0.0 - NMZ =0.0 - JIPC0=NCP0*(IP0-1) - DO 33 IC1=1,NCPM1 - JIPC=JIPC0+IC1 - IPI=IPC(JIPC) - DX1=XD(IPI)-X0 - DY1=YD(IPI)-Y0 - JPD=5*IPI - DZX1=PD(JPD-4)-ZX0 - DZY1=PD(JPD-3)-ZY0 - IC2MN=IC1+1 - DO 32 IC2=IC2MN,NCP0 - JIPC=JIPC0+IC2 - IPI=IPC(JIPC) - DX2=XD(IPI)-X0 - DY2=YD(IPI)-Y0 - DNMZ =DX1*DY2 -DY1*DX2 - IF(DNMZ.EQ.0.0) GO TO 32 - JPD=5*IPI - DZX2=PD(JPD-4)-ZX0 - DZY2=PD(JPD-3)-ZY0 - DNMXX=DY1*DZX2-DZX1*DY2 - DNMXY=DZX1*DX2-DX1*DZX2 - DNMYX=DY1*DZY2-DZY1*DY2 - DNMYY=DZY1*DX2-DX1*DZY2 - IF(DNMZ.GE.0.0) GO TO 31 - DNMXX=-DNMXX - DNMXY=-DNMXY - DNMYX=-DNMYX - DNMYY=-DNMYY - DNMZ =-DNMZ - 31 NMXX=NMXX+DNMXX - NMXY=NMXY+DNMXY - NMYX=NMYX+DNMYX - NMYY=NMYY+DNMYY - NMZ =NMZ +DNMZ - 32 CONTINUE - 33 CONTINUE - PD(JPD0-2)=-NMXX/NMZ - PD(JPD0-1)=-(NMXY+NMYX)/(2.0*NMZ) - PD(JPD0) =-NMYY/NMZ - 34 CONTINUE - RETURN - END diff --git a/src/idptip.f b/src/idptip.f deleted file mode 100644 index 3013b84f306290e879180f4eb8a220d582345042..0000000000000000000000000000000000000000 --- a/src/idptip.f +++ /dev/null @@ -1,296 +0,0 @@ - - SUBROUTINE IDPTIP(XD,YD,ZD,NDP,NT,IPT,NL,IPL,PDD,ITI,XII,YII, ID010190 - 1 ZII,MISSII) -C THIS SUBROUTINE PERFORMS PUNCTUAL INTERPOLATION OR EXTRAPOLA- -C TION, I.E., DETERMINES THE Z VALUE AT A POINT. - -C THE INPUT PARAMETERS ARE -C XD,YD,ZD = ARRAYS OF DIMENSION NDP CONTAINING THE X, -C Y, AND Z COORDINATES OF THE DATA POINTS, WHERE -C NDP IS THE NUMBER OF THE DATA POINTS, -C NT = NUMBER OF TRIANGLES, -C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE -C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, -C NL = NUMBER OF BORDER LINE SEGMENTS, -C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE -C POINT NUMBERS OF THE END POINTS OF THE BORDER -C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE -C NUMBERS, -C PDD = ARRAY OF DIMENSION 5*NDP CONTAINING THE PARTIAL -C DERIVATIVES AT THE DATA POINTS, -C ITI = TRIANGLE NUMBER OF THE TRIANGLE IN WHICH LIES -C THE POINT FOR WHICH INTERPOLATION IS TO BE -C PERFORMED, -C XII,YII = X AND Y COORDINATES OF THE POINT FOR WHICH -C INTERPOLATION IS TO BE PERFORMED. - -C THE OUTPUT PARAMETERs are -C ZII = INTERPOLATED Z VALUE. -C MISSII = LOCIGAL INDICATING MISSING VALUE - -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - LOGICAL MISSII - DIMENSION XD(NDP),YD(NDP),ZD(NDP),IPT(3*NT),IPL(3*NL), - 1 PDD(5*NDP) - COMMON/IDPI/ITPV - DIMENSION X(3),Y(3),Z(3),PD(15), - 1 ZU(3),ZV(3),ZUU(3),ZUV(3),ZVV(3) - DOUBLE PRECISION LU,LV - EQUIVALENCE (P5,P50) - -C PRELIMINARY PROCESSING - 10 IT0=ITI - NTL=NT+NL - IF(IT0.LE.NTL) GO TO 20 -C EXTRAPOLATION OR MISSING VALUE WANTED? - IF (MISSII) THEN - ZII=0 - RETURN - END IF - IL1=IT0/NTL - IL2=IT0-IL1*NTL - IF(IL1.EQ.IL2) GO TO 40 - GO TO 60 -C CALCULATION OF ZII BY INTERPOLATION. -C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. - 20 IF(IT0.EQ.ITPV) GO TO 30 -C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE -C VERTEXES. - 21 JIPT=3*(IT0-1) - JPD=0 - DO 23 I=1,3 - JIPT=JIPT+1 - IDP=IPT(JIPT) - X(I)=XD(IDP) - Y(I)=YD(IDP) - Z(I)=ZD(IDP) - JPDD=5*(IDP-1) - DO 22 KPD=1,5 - JPD=JPD+1 - JPDD=JPDD+1 - PD(JPD)=PDD(JPDD) - 22 CONTINUE - 23 CONTINUE -C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM -C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM -C AND VICE VERSA. - 24 X0=X(1) - Y0=Y(1) - A=X(2)-X0 - B=X(3)-X0 - C=Y(2)-Y0 - D=Y(3)-Y0 - AD=A*D - BC=B*C - DLT=AD-BC - AP= D/DLT - BP=-B/DLT - CP=-C/DLT - DP= A/DLT -C CONVERTS THE PARTIAL DERIVATIVES AT THE VERTEXES OF THE -C TRIANGLE FOR THE U-V COORDINATE SYSTEM. - 25 AA=A*A - ACT2=2.0*A*C - CC=C*C - AB=A*B - ADBC=AD+BC - CD=C*D - BB=B*B - BDT2=2.0*B*D - DD=D*D - DO 26 I=1,3 - JPD=5*I - ZU(I)=A*PD(JPD-4)+C*PD(JPD-3) - ZV(I)=B*PD(JPD-4)+D*PD(JPD-3) - ZUU(I)=AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) - ZUV(I)=AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) - ZVV(I)=BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) - 26 CONTINUE -C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. - 27 P00=Z(1) - P10=ZU(1) - P01=ZV(1) - P20=0.5*ZUU(1) - P11=ZUV(1) - P02=0.5*ZVV(1) - H1=Z(2)-P00-P10-P20 - H2=ZU(2)-P10-ZUU(1) - H3=ZUU(2)-ZUU(1) - P30= 10.0*H1-4.0*H2+0.5*H3 - P40=-15.0*H1+7.0*H2 -H3 - P50= 6.0*H1-3.0*H2+0.5*H3 - H1=Z(3)-P00-P01-P02 - H2=ZV(3)-P01-ZVV(1) - H3=ZVV(3)-ZVV(1) - P03= 10.0*H1-4.0*H2+0.5*H3 - P04=-15.0*H1+7.0*H2 -H3 - P05= 6.0*H1-3.0*H2+0.5*H3 - LU=SQRT(AA+CC) - LV=SQRT(BB+DD) - THXU=ATAN2(C,A) - THUV=ATAN2(D,B)-THXU - CSUV=COS(THUV) - P41=5.0*LV*CSUV/LU*P50 - P14=5.0*LU*CSUV/LV*P05 - H1=ZV(2)-P01-P11-P41 - H2=ZUV(2)-P11-4.0*P41 - P21= 3.0*H1-H2 - P31=-2.0*H1+H2 - H1=ZU(3)-P10-P11-P14 - H2=ZUV(3)-P11-4.0*P14 - P12= 3.0*H1-H2 - P13=-2.0*H1+H2 - THUS=ATAN2(D-C,B-A)-THXU - THSV=THUV-THUS - AA= SIN(THSV)/LU - BB=-COS(THSV)/LU - CC= SIN(THUS)/LV - DD= COS(THUS)/LV - AC=AA*CC - AD=AA*DD - BC=BB*CC - G1=AA*AC*(3.0*BC+2.0*AD) - G2=CC*AC*(3.0*AD+2.0*BC) - H1=-AA*AA*AA*(5.0*AA*BB*P50+(4.0*BC+AD)*P41) - 1 -CC*CC*CC*(5.0*CC*DD*P05+(4.0*AD+BC)*P14) - H2=0.5*ZVV(2)-P02-P12 - H3=0.5*ZUU(3)-P20-P21 - P22=(G1*H2+G2*H3-H1)/(G1+G2) - P32=H2-P22 - P23=H3-P22 - ITPV=IT0 -C CONVERTS XII AND YII TO U-V SYSTEM. - 30 DX=XII-X0 - DY=YII-Y0 - U=AP*DX+BP*DY - V=CP*DX+DP*DY -C EVALUATES THE POLYNOMIAL. - 31 P0=P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) - P1=P10+V*(P11+V*(P12+V*(P13+V*P14))) - P2=P20+V*(P21+V*(P22+V*P23)) - P3=P30+V*(P31+V*P32) - P4=P40+V*P41 - ZII=P0+U*(P1+U*(P2+U*(P3+U*(P4+U*P5)))) - MISSII=.FALSE. - RETURN - -C CALCULATION OF ZII BY EXTRAPOLATION IN THE RECTANGLE. -C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. - 40 IF(IT0.EQ.ITPV) GO TO 50 -C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE END -C POINTS OF THE BORDER LINE SEGMENT. - 41 JIPL=3*(IL1-1) - JPD=0 - DO 43 I=1,2 - JIPL=JIPL+1 - IDP=IPL(JIPL) - X(I)=XD(IDP) - Y(I)=YD(IDP) - Z(I)=ZD(IDP) - JPDD=5*(IDP-1) - DO 42 KPD=1,5 - JPD=JPD+1 - JPDD=JPDD+1 - PD(JPD)=PDD(JPDD) - 42 CONTINUE - 43 CONTINUE -C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM -C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM -C AND VICE VERSA. - 44 X0=X(1) - Y0=Y(1) - A=Y(2)-Y(1) - B=X(2)-X(1) - C=-B - D=A - AD=A*D - BC=B*C - DLT=AD-BC - AP= D/DLT - BP=-B/DLT - CP=-BP - DP= AP -C CONVERTS THE PARTIAL DERIVATIVES AT THE END POINTS OF THE -C BORDER LINE SEGMENT FOR THE U-V COORDINATE SYSTEM. - 45 AA=A*A - ACT2=2.0*A*C - CC=C*C - AB=A*B - ADBC=AD+BC - CD=C*D - BB=B*B - BDT2=2.0*B*D - DD=D*D - DO 46 I=1,2 - JPD=5*I - ZU(I)=A*PD(JPD-4)+C*PD(JPD-3) - ZV(I)=B*PD(JPD-4)+D*PD(JPD-3) - ZUU(I)=AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) - ZUV(I)=AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) - ZVV(I)=BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) - 46 CONTINUE -C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. - 47 P00=Z(1) - P10=ZU(1) - P01=ZV(1) - P20=0.5*ZUU(1) - P11=ZUV(1) - P02=0.5*ZVV(1) - H1=Z(2)-P00-P01-P02 - H2=ZV(2)-P01-ZVV(1) - H3=ZVV(2)-ZVV(1) - P03= 10.0*H1-4.0*H2+0.5*H3 - P04=-15.0*H1+7.0*H2 -H3 - P05= 6.0*H1-3.0*H2+0.5*H3 - H1=ZU(2)-P10-P11 - H2=ZUV(2)-P11 - P12= 3.0*H1-H2 - P13=-2.0*H1+H2 - P21=0.0 - P23=-ZUU(2)+ZUU(1) - P22=-1.5*P23 - ITPV=IT0 -C CONVERTS XII AND YII TO U-V SYSTEM. - 50 DX=XII-X0 - DY=YII-Y0 - U=AP*DX+BP*DY - V=CP*DX+DP*DY -C EVALUATES THE POLYNOMIAL. - 51 P0=P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) - P1=P10+V*(P11+V*(P12+V*P13)) - P2=P20+V*(P21+V*(P22+V*P23)) - ZII=P0+U*(P1+U*P2) - RETURN -C CALCULATION OF ZII BY EXTRAPOLATION IN THE TRIANGLE. -C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. - 60 IF(IT0.EQ.ITPV) GO TO 70 -C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE VERTEX -C OF THE TRIANGLE. - 61 JIPL=3*IL2-2 - IDP=IPL(JIPL) - X(1)=XD(IDP) - Y(1)=YD(IDP) - Z(1)=ZD(IDP) - JPDD=5*(IDP-1) - DO 62 KPD=1,5 - JPDD=JPDD+1 - PD(KPD)=PDD(JPDD) - 62 CONTINUE -C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. - 67 P00=Z(1) - P10=PD(1) - P01=PD(2) - P20=0.5*PD(3) - P11=PD(4) - P02=0.5*PD(5) - ITPV=IT0 -C CONVERTS XII AND YII TO U-V SYSTEM. - 70 U=XII-X(1) - V=YII-Y(1) -C EVALUATES THE POLYNOMIAL. - 71 P0=P00+V*(P01+V*P02) - P1=P10+V*P11 - ZII=P0+U*(P1+U*P20) - RETURN - END diff --git a/src/idptli.f b/src/idptli.f deleted file mode 100644 index f2cdf6cb4a320fbe17c093e39ec0a8e81845df6f..0000000000000000000000000000000000000000 --- a/src/idptli.f +++ /dev/null @@ -1,86 +0,0 @@ - - SUBROUTINE IDPTLI(XD,YD,ZD,NDP,NT,IPT,NL,IPL,ITI,XII,YII,ZII, - 1 MISSII) ID010191 -C THIS SUBROUTINE PERFORMS LINEAR PUNCTUAL INTERPOLATION, -C I.E., DETERMINES THE Z VALUE AT A POINT. -C THE INPUT PARAMETERS ARE -C XD,YD,ZD = ARRAYS OF DIMENSION NDP CONTAINING THE X, -C Y, AND Z COORDINATES OF THE DATA POINTS, WHERE -C NDP IS THE NUMBER OF THE DATA POINTS, -C NT = NUMBER OF TRIANGLES, -C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE -C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, -C NL = NUMBER OF BORDER LINE SEGMENTS, -C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE -C POINT NUMBERS OF THE END POINTS OF THE BORDER -C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE -C NUMBERS, -C ITI = TRIANGLE NUMBER OF THE TRIANGLE IN WHICH LIES -C THE POINT FOR WHICH INTERPOLATION IS TO BE -C PERFORMED, -C XII,YII = X AND Y COORDINATES OF THE POINT FOR WHICH -C INTERPOLATION IS TO BE PERFORMED. -C THE OUTPUT PARAMETERS ARE -C ZII = INTERPOLATED Z VALUE. -C MISSII = LOCIGAL INDICATING MISSING VALUE -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - LOGICAL MISSII - DIMENSION XD(NDP),YD(NDP),ZD(NDP),IPT(3*NT),IPL(3*NL) - COMMON/IDPI/ITPV - DIMENSION X(3),Y(3),Z(3) - EQUIVALENCE (P5,P50) -C PRELIMINARY PROCESSING - 10 IT0=ITI - NTL=NT+NL - IF(IT0.LE.NTL) GO TO 20 - GO TO 40 -C CALCULATION OF ZII BY INTERPOLATION. -C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. - 20 IF(IT0.EQ.ITPV) GO TO 30 -C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE -C VERTEXES. - 21 JIPT=3*(IT0-1) - JPD=0 - DO 23 I=1,3 - JIPT=JIPT+1 - IDP=IPT(JIPT) - X(I)=XD(IDP) - Y(I)=YD(IDP) - Z(I)=ZD(IDP) - 23 CONTINUE -C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM -C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM -C AND VICE VERSA. - 24 X0=X(1) - Y0=Y(1) - A=X(2)-X0 - B=X(3)-X0 - C=Y(2)-Y0 - D=Y(3)-Y0 - AD=A*D - BC=B*C - DLT=AD-BC - AP= D/DLT - BP=-B/DLT - CP=-C/DLT - DP= A/DLT -C CONVERTS XII AND YII TO U-V SYSTEM. - 30 DX=XII-X0 - DY=YII-Y0 - U=AP*DX+BP*DY - V=CP*DX+DP*DY -C EVALUATES THE INTERPOLATED PLANE -C ACCORDING TO -C | U V ZII-Z1 | -C | 1 0 Z2-Z1 | = 0 -C | 0 1 Z3-Z1 | -C - ZII=Z(1)+U*(Z(2)-Z(1))+V*(Z(3)-Z(1)) - MISSII=.FALSE. - RETURN -C NO EXTRAPOLATION! - 40 ZII=0 - MISSII=.TRUE. - RETURN - END diff --git a/src/idsfft.f b/src/idsfft.f deleted file mode 100644 index 24953c95b474d0859caf6228518304708276a3f1..0000000000000000000000000000000000000000 --- a/src/idsfft.f +++ /dev/null @@ -1,187 +0,0 @@ - - SUBROUTINE IDSFFT(MD,NCP,NDP,XD,YD,ZD,NXI,NYI,XI,YI,ZI, ID013070 - 1 IWK,WK,MISSI) -C THIS SUBROUTINE PERFORMS SMOOTH SURFACE FITTING WHEN THE PRO- -C JECTIONS OF THE DATA POINTS IN THE X-Y PLANE ARE IRREGULARLY -C DISTRIBUTED IN THE PLANE. -C THE INPUT PARAMETERS ARE -C MD = MODE OF COMPUTATION (MUST BE 1, 2, OR 3), -C = 1 FOR NEW NCP AND/OR NEW XD-YD, -C = 2 FOR OLD NCP, OLD XD-YD, NEW XI-YI, -C = 3 FOR OLD NCP, OLD XD-YD, OLD XI-YI, -C NCP = NUMBER OF ADDITIONAL DATA POINTS USED FOR ESTI- -C MATING PARTIAL DERIVATIVES AT EACH DATA POINT -C (MUST BE 2 OR GREATER, BUT SMALLER THAN NDP), -C NDP = NUMBER OF DATA POINTS (MUST BE 4 OR GREATER), -C XD = ARRAY OF DIMENSION NDP CONTAINING THE X -C COORDINATES OF THE DATA POINTS, -C YD = ARRAY OF DIMENSION NDP CONTAINING THE Y -C COORDINATES OF THE DATA POINTS, -C ZD = ARRAY OF DIMENSION NDP CONTAINING THE Z -C COORDINATES OF THE DATA POINTS, -C NXI = NUMBER OF OUTPUT GRID POINTS IN THE X COORDINATE -C (MUST BE 1 OR GREATER), -C NYI = NUMBER OF OUTPUT GRID POINTS IN THE Y COORDINATE -C (MUST BE 1 OR GREATER), -C XI = ARRAY OF DIMENSION NXI CONTAINING THE X -C COORDINATES OF THE OUTPUT GRID POINTS, -C YI = ARRAY OF DIMENSION NYI CONTAINING THE Y -C COORDINATES OF THE OUTPUT GRID POINTS. -C THE OUTPUT PARAMETER IS -C ZI = DOUBLY-DIMENSIONED ARRAY OF DIMENSION (NXI,NYI), -C WHERE THE INTERPOLATED Z VALUES AT THE OUTPUT -C GRID POINTS ARE TO BE STORED. -C THE OTHER PARAMETERS ARE -C IWK = INTEGER ARRAY OF DIMENSION -C MAX0(31,27+NCP)*NDP+NXI*NYI -C USED INTERNALLY AS A WORK AREA, -C WK = ARRAY OF DIMENSION 5*NDP USED INTERNALLY AS A -C WORK AREA. -C MISSI = LOCICAL ARRAY, INDICATING IF EXTRAPOLATION OR MISSING VALUES -C OUTSIDE CONVEX HULL WANTED -C THE VERY FIRST CALL TO THIS SUBROUTINE AND THE CALL WITH A NEW -C NCP VALUE, A NEW NDP VALUE, AND/OR NEW CONTENTS OF THE XD AND -C YD ARRAYS MUST BE MADE WITH MD=1. THE CALL WITH MD=2 MUST BE -C PRECEDED BY ANOTHER CALL WITH THE SAME NCP AND NDP VALUES AND -C WITH THE SAME CONTENTS OF THE XD AND YD ARRAYS. THE CALL WITH -C MD=3 MUST BE PRECEDED BY ANOTHER CALL WITH THE SAME NCP, NDP, -C NXI, AND NYI VALUES AND WITH THE SAME CONTENTS OF THE XD, YD, -C XI, AND YI ARRAYS. BETWEEN THE CALL WITH MD=2 OR MD=3 AND ITS -C PRECEDING CALL, THE IWK AND WK ARRAYS MUST NOT BE DISTURBED. -C USE OF A VALUE BETWEEN 3 AND 5 (INCLUSIVE) FOR NCP IS RECOM- -C MENDED UNLESS THERE ARE EVIDENCES THAT DICTATE OTHERWISE. -C THE LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE -C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, -C THEREFORE, SYSTEM DEPENDENT. -C THIS SUBROUTINE CALLS THE IDCLDP, IDGRID, IDPDRV, IDPTIP, AND -C IDTANG SUBROUTINES. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - LOGICAL MISSI, LINEAR - DIMENSION XD(NDP),YD(NDP),ZD(NDP),XI(NXI),YI(NYI), - 1 ZI(NXI*NYI),MISSI(NXI*NYI),IWK((31+NCP)*NDP+NXI*NYI), - 2 WK(5*NDP) - COMMON/IDPI/ITPV - DATA LUN/6/ - LINEAR=.FALSE. -C SETTING OF SOME INPUT PARAMETERS TO LOCAL VARIABLES. -C (FOR MD=1,2,3) - 10 MD0=MD - NCP0=NCP - NDP0=NDP - NXI0=NXI - NYI0=NYI -C ERROR CHECK. (FOR MD=1,2,3) - 20 IF(MD0.LT.1.OR.MD0.GT.3) GO TO 90 - IF(NCP0.EQ.0) THEN - LINEAR=.TRUE. - DO 21 I=1,NXI*NYI - MISSI(I)=.TRUE. - 21 CONTINUE - END IF - IF(NCP0.EQ.1.OR.NCP0.GE.NDP0) GO TO 90 - IF(NDP0.LT.4) GO TO 90 - IF(NXI0.LT.1.OR.NYI0.LT.1) GO TO 90 - IF(MD0.GE.2) GO TO 23 - IWK(1)=NCP0 - IWK(2)=NDP0 - GO TO 24 - 23 NCPPV=IWK(1) - NDPPV=IWK(2) - IF(NCP0.NE.NCPPV) GO TO 90 - IF(NDP0.NE.NDPPV) GO TO 90 - 24 IF(MD0.GE.3) GO TO 25 - IWK(3)=NXI0 - IWK(4)=NYI0 - GO TO 30 - 25 NXIPV=IWK(3) - NYIPV=IWK(4) - IF(NXI0.NE.NXIPV) GO TO 90 - IF(NYI0.NE.NYIPV) GO TO 90 -C ALLOCATION OF STORAGE AREAS IN THE IWK ARRAY. (FOR MD=1,2,3) - 30 JWIPT=16 - JWIWL=6*NDP0+1 - JWNGP0=JWIWL-1 - JWIPL=24*NDP0+1 - JWIWP=30*NDP0+1 - JWIPC=27*NDP0+1 - JWIGP0=MAX0(31,27+NCP0)*NDP0 -C TRIANGULATES THE X-Y PLANE. (FOR MD=1) - 40 IF(MD0.GT.1) GO TO 50 - CALL IDTANG(NDP0,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL), - 1 IWK(JWIWL),IWK(JWIWP),WK) - IWK(5)=NT - IWK(6)=NL - IF(NT.EQ.0) RETURN -C DETERMINES NCP POINTS CLOSEST TO EACH DATA POINT. (FOR MD=1) - 50 IF(MD0.GT.1 .OR. LINEAR) GO TO 60 - CALL IDCLDP(NDP0,XD,YD,NCP0,IWK(JWIPC)) - IF(IWK(JWIPC).EQ.0) RETURN -C SORTS OUTPUT GRID POINTS IN ASCENDING ORDER OF THE TRIANGLE -C NUMBER AND THE BORDER LINE SEGMENT NUMBER. (FOR MD=1,2) - 60 IF(MD0.EQ.3) GO TO 70 - CALL IDGRID(XD,YD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),NXI0,NYI0, - 1 XI,YI,IWK(JWNGP0+1),IWK(JWIGP0+1)) -C ESTIMATES PARTIAL DERIVATIVES AT ALL DATA POINTS. -C (FOR MD=1,2,3) - 70 IF (.NOT.LINEAR) CALL IDPDRV(NDP0,XD,YD,ZD,NCP0,IWK(JWIPC),WK) -C INTERPOLATES THE ZI VALUES. (FOR MD=1,2,3) - 80 ITPV=0 - JIG0MX=0 - JIG1MN=NXI0*NYI0+1 - NNGP=NT+2*NL - DO 89 JNGP=1,NNGP - ITI=JNGP - IF(JNGP.LE.NT) GO TO 81 - IL1=(JNGP-NT+1)/2 - IL2=(JNGP-NT+2)/2 - IF(IL2.GT.NL) IL2=1 - ITI=IL1*(NT+NL)+IL2 - 81 JWNGP=JWNGP0+JNGP - NGP0=IWK(JWNGP) - IF(NGP0.EQ.0) GO TO 86 - JIG0MN=JIG0MX+1 - JIG0MX=JIG0MX+NGP0 - DO 82 JIGP=JIG0MN,JIG0MX - JWIGP=JWIGP0+JIGP - IZI=IWK(JWIGP) - IYI=(IZI-1)/NXI0+1 - IXI=IZI-NXI0*(IYI-1) - IF (LINEAR) THEN - CALL IDPTLI(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL), - 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) - ELSE - CALL IDPTIP(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),WK, - 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) - END IF - 82 CONTINUE - 86 JWNGP=JWNGP0+2*NNGP+1-JNGP - NGP1=IWK(JWNGP) - IF(NGP1.EQ.0) GO TO 89 - JIG1MX=JIG1MN-1 - JIG1MN=JIG1MN-NGP1 - DO 87 JIGP=JIG1MN,JIG1MX - JWIGP=JWIGP0+JIGP - IZI=IWK(JWIGP) - IYI=(IZI-1)/NXI0+1 - IXI=IZI-NXI0*(IYI-1) - IF (LINEAR) THEN - CALL IDPTLI(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL), - 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) - ELSE - CALL IDPTIP(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),WK, - 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) - END IF - 87 CONTINUE - 89 CONTINUE - RETURN -C ERROR EXIT - 90 CONTINUE -C WRITE (LUN,2090) MD0,NCP0,NDP0,NXI0,NYI0 - RETURN -C FORMAT STATEMENT FOR ERROR MESSAGE - 2090 FORMAT(1X/41H *** IMPROPER INPUT PARAMETER VALUE(S)./ - 1 7H MD =,I4,10X,5HNCP =,I6,10X,5HNDP =,I6, - 2 10X,5HNXI =,I6,10X,5HNYI =,I6/ - 3 35H ERROR DETECTED IN ROUTINE IDSFFT/) - END diff --git a/src/idtang.f b/src/idtang.f deleted file mode 100644 index 6ea6ae00463faaa0f4212cf1d25ba49f99589cfb..0000000000000000000000000000000000000000 --- a/src/idtang.f +++ /dev/null @@ -1,378 +0,0 @@ - - SUBROUTINE IDTANG(NDP,XD,YD,NT,IPT,NL,IPL,IWL,IWP,WK) ID014770 -C THIS SUBROUTINE PERFORMS TRIANGULATION. IT DIVIDES THE X-Y -C PLANE INTO A NUMBER OF TRIANGLES ACCORDING TO GIVEN DATA -C POINTS IN THE PLANE, DETERMINES LINE SEGMENTS THAT FORM THE -C BORDER OF DATA AREA, AND DETERMINES THE TRIANGLE NUMBERS -C CORRESPONDING TO THE BORDER LINE SEGMENTS. -C AT COMPLETION, POINT NUMBERS OF THE VERTEXES OF EACH TRIANGLE -C ARE LISTED COUNTER-CLOCKWISE. POINT NUMBERS OF THE END POINTS -C OF EACH BORDER LINE SEGMENT ARE LISTED COUNTER-CLOCKWISE, -C LISTING ORDER OF THE LINE SEGMENTS BEING COUNTER-CLOCKWISE. -C THE LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE -C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, -C THEREFORE, SYSTEM DEPENDENT. -C THIS SUBROUTINE CALLS THE IDXCHG FUNCTION. -C THE INPUT PARAMETERS ARE -C NDP = NUMBER OF DATA POINTS, -C XD = ARRAY OF DIMENSION NDP CONTAINING THE -C X COORDINATES OF THE DATA POINTS, -C YD = ARRAY OF DIMENSION NDP CONTAINING THE -C Y COORDINATES OF THE DATA POINTS. -C THE OUTPUT PARAMETERS ARE -C NT = NUMBER OF TRIANGLES, -C IPT = INTEGER ARRAY OF DIMENSION 6*NDP-15, WHERE THE -C POINT NUMBERS OF THE VERTEXES OF THE (IT)TH -C TRIANGLE ARE TO BE STORED AS THE (3*IT-2)ND, -C (3*IT-1)ST, AND (3*IT)TH ELEMENTS, -C IT=1,2,...,NT, -C NL = NUMBER OF BORDER LINE SEGMENTS, -C IPL = INTEGER ARRAY OF DIMENSION 6*NDP, WHERE THE -C POINT NUMBERS OF THE END POINTS OF THE (IL)TH -C BORDER LINE SEGMENT AND ITS RESPECTIVE TRIANGLE -C NUMBER ARE TO BE STORED AS THE (3*IL-2)ND, -C (3*IL-1)ST, AND (3*IL)TH ELEMENTS, -C IL=1,2,..., NL. -C THE OTHER PARAMETERS ARE -C IWL = INTEGER ARRAY OF DIMENSION 18*NDP USED -C INTERNALLY AS A WORK AREA, -C IWP = INTEGER ARRAY OF DIMENSION NDP USED -C INTERNALLY AS A WORK AREA, -C WK = ARRAY OF DIMENSION NDP USED INTERNALLY AS A -C WORK AREA. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - DIMENSION XD(NDP),YD(NDP),IPT(6*NDP-15),IPL(6*NDP), - 1 IWL(18*NDP),IWP(NDP),WK(NDP) - DIMENSION ITF(2) - DATA RATIO/1.0E-6/, NREP/100/, LUN/6/ -C STATEMENT FUNCTIONS - DSQF(U1,V1,U2,V2)=(U2-U1)**2+(V2-V1)**2 - SIDE(U1,V1,U2,V2,U3,V3)=(V3-V1)*(U2-U1)-(U3-U1)*(V2-V1) -C PRELIMINARY PROCESSING - 10 NDP0=NDP - NDPM1=NDP0-1 - IF(NDP0.LT.4) GO TO 90 -C DETERMINES THE CLOSEST PAIR OF DATA POINTS AND THEIR MIDPOINT. - 20 DSQMN=DSQF(XD(1),YD(1),XD(2),YD(2)) - IPMN1=1 - IPMN2=2 - DO 22 IP1=1,NDPM1 - X1=XD(IP1) - Y1=YD(IP1) - IP1P1=IP1+1 - DO 21 IP2=IP1P1,NDP0 - DSQI=DSQF(X1,Y1,XD(IP2),YD(IP2)) - IF(DSQI.EQ.0.0) GO TO 91 - IF(DSQI.GE.DSQMN) GO TO 21 - DSQMN=DSQI - IPMN1=IP1 - IPMN2=IP2 - 21 CONTINUE - 22 CONTINUE - DSQ12=DSQMN - XDMP=(XD(IPMN1)+XD(IPMN2))/2.0 - YDMP=(YD(IPMN1)+YD(IPMN2))/2.0 -C SORTS THE OTHER (NDP-2) DATA POINTS IN ASCENDING ORDER OF -C DISTANCE FROM THE MIDPOINT AND STORES THE SORTED DATA POINT -C NUMBERS IN THE IWP ARRAY. - 30 JP1=2 - DO 31 IP1=1,NDP0 - IF(IP1.EQ.IPMN1.OR.IP1.EQ.IPMN2) GO TO 31 - JP1=JP1+1 - IWP(JP1)=IP1 - WK(JP1)=DSQF(XDMP,YDMP,XD(IP1),YD(IP1)) - 31 CONTINUE - DO 33 JP1=3,NDPM1 - DSQMN=WK(JP1) - JPMN=JP1 - DO 32 JP2=JP1,NDP0 - IF(WK(JP2).GE.DSQMN) GO TO 32 - DSQMN=WK(JP2) - JPMN=JP2 - 32 CONTINUE - ITS=IWP(JP1) - IWP(JP1)=IWP(JPMN) - IWP(JPMN)=ITS - WK(JPMN)=WK(JP1) - 33 CONTINUE -C IF NECESSARY, MODIFIES THE ORDERING IN SUCH A WAY THAT THE -C FIRST THREE DATA POINTS ARE NOT COLLINEAR. - 35 AR=DSQ12*RATIO - X1=XD(IPMN1) - Y1=YD(IPMN1) - DX21=XD(IPMN2)-X1 - DY21=YD(IPMN2)-Y1 - DO 36 JP=3,NDP0 - IP=IWP(JP) - IF(ABS((YD(IP)-Y1)*DX21-(XD(IP)-X1)*DY21).GT.AR) - 1 GO TO 37 - 36 CONTINUE - GO TO 92 - 37 IF(JP.EQ.3) GO TO 40 - JPMX=JP - JP=JPMX+1 - DO 38 JPC=4,JPMX - JP=JP-1 - IWP(JP)=IWP(JP-1) - 38 CONTINUE - IWP(3)=IP -C FORMS THE FIRST TRIANGLE. STORES POINT NUMBERS OF THE VER- -C TEXES OF THE TRIANGLE IN THE IPT ARRAY, AND STORES POINT NUM- -C BERS OF THE BORDER LINE SEGMENTS AND THE TRIANGLE NUMBER IN -C THE IPL ARRAY. - 40 IP1=IPMN1 - IP2=IPMN2 - IP3=IWP(3) - IF(SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) - 1 .GE.0.0) GO TO 41 - IP1=IPMN2 - IP2=IPMN1 - 41 NT0=1 - NTT3=3 - IPT(1)=IP1 - IPT(2)=IP2 - IPT(3)=IP3 - NL0=3 - NLT3=9 - IPL(1)=IP1 - IPL(2)=IP2 - IPL(3)=1 - IPL(4)=IP2 - IPL(5)=IP3 - IPL(6)=1 - IPL(7)=IP3 - IPL(8)=IP1 - IPL(9)=1 -C ADDS THE REMAINING (NDP-3) DATA POINTS, ONE BY ONE. - 50 DO 79 JP1=4,NDP0 - IP1=IWP(JP1) - X1=XD(IP1) - Y1=YD(IP1) -C - DETERMINES THE VISIBLE BORDER LINE SEGMENTS. - IP2=IPL(1) - JPMN=1 - DXMN=XD(IP2)-X1 - DYMN=YD(IP2)-Y1 - DSQMN=DXMN**2+DYMN**2 - ARMN=DSQMN*RATIO - JPMX=1 - DXMX=DXMN - DYMX=DYMN - DSQMX=DSQMN - ARMX=ARMN - DO 52 JP2=2,NL0 - IP2=IPL(3*JP2-2) - DX=XD(IP2)-X1 - DY=YD(IP2)-Y1 - AR=DY*DXMN-DX*DYMN - IF(AR.GT.ARMN) GO TO 51 - DSQI=DX**2+DY**2 - IF(AR.GE.(-ARMN).AND.DSQI.GE.DSQMN) GO TO 51 - JPMN=JP2 - DXMN=DX - DYMN=DY - DSQMN=DSQI - ARMN=DSQMN*RATIO - 51 AR=DY*DXMX-DX*DYMX - IF(AR.LT.(-ARMX)) GO TO 52 - DSQI=DX**2+DY**2 - IF(AR.LE.ARMX.AND.DSQI.GE.DSQMX) GO TO 52 - JPMX=JP2 - DXMX=DX - DYMX=DY - DSQMX=DSQI - ARMX=DSQMX*RATIO - 52 CONTINUE - IF(JPMX.LT.JPMN) JPMX=JPMX+NL0 - NSH=JPMN-1 - IF(NSH.LE.0) GO TO 60 -C - SHIFTS (ROTATES) THE IPL ARRAY TO HAVE THE INVISIBLE BORDER -C - LINE SEGMENTS CONTAINED IN THE FIRST PART OF THE IPL ARRAY. - NSHT3=NSH*3 - DO 53 JP2T3=3,NSHT3,3 - JP3T3=JP2T3+NLT3 - IPL(JP3T3-2)=IPL(JP2T3-2) - IPL(JP3T3-1)=IPL(JP2T3-1) - IPL(JP3T3) =IPL(JP2T3) - 53 CONTINUE - DO 54 JP2T3=3,NLT3,3 - JP3T3=JP2T3+NSHT3 - IPL(JP2T3-2)=IPL(JP3T3-2) - IPL(JP2T3-1)=IPL(JP3T3-1) - IPL(JP2T3) =IPL(JP3T3) - 54 CONTINUE - JPMX=JPMX-NSH -C - ADDS TRIANGLES TO THE IPT ARRAY, UPDATES BORDER LINE -C - SEGMENTS IN THE IPL ARRAY, AND SETS FLAGS FOR THE BORDER -C - LINE SEGMENTS TO BE REEXAMINED IN THE IWL ARRAY. - 60 JWL=0 - DO 64 JP2=JPMX,NL0 - JP2T3=JP2*3 - IPL1=IPL(JP2T3-2) - IPL2=IPL(JP2T3-1) - IT =IPL(JP2T3) -C - - ADDS A TRIANGLE TO THE IPT ARRAY. - NT0=NT0+1 - NTT3=NTT3+3 - IPT(NTT3-2)=IPL2 - IPT(NTT3-1)=IPL1 - IPT(NTT3) =IP1 -C - - UPDATES BORDER LINE SEGMENTS IN THE IPL ARRAY. - IF(JP2.NE.JPMX) GO TO 61 - IPL(JP2T3-1)=IP1 - IPL(JP2T3) =NT0 - 61 IF(JP2.NE.NL0) GO TO 62 - NLN=JPMX+1 - NLNT3=NLN*3 - IPL(NLNT3-2)=IP1 - IPL(NLNT3-1)=IPL(1) - IPL(NLNT3) =NT0 -C - - DETERMINES THE VERTEX THAT DOES NOT LIE ON THE BORDER -C - - LINE SEGMENTS. - 62 ITT3=IT*3 - IPTI=IPT(ITT3-2) - IF(IPTI.NE.IPL1.AND.IPTI.NE.IPL2) GO TO 63 - IPTI=IPT(ITT3-1) - IF(IPTI.NE.IPL1.AND.IPTI.NE.IPL2) GO TO 63 - IPTI=IPT(ITT3) -C - - CHECKS IF THE EXCHANGE IS NECESSARY. - 63 IF(IDXCHG(XD,YD,NDP,IP1,IPTI,IPL1,IPL2).EQ.0) GO TO 64 -C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. - IPT(ITT3-2)=IPTI - IPT(ITT3-1)=IPL1 - IPT(ITT3) =IP1 - IPT(NTT3-1)=IPTI - IF(JP2.EQ.JPMX) IPL(JP2T3)=IT - IF(JP2.EQ.NL0.AND.IPL(3).EQ.IT) IPL(3)=NT0 -C - - SETS FLAGS IN THE IWL ARRAY. - JWL=JWL+4 - IWL(JWL-3)=IPL1 - IWL(JWL-2)=IPTI - IWL(JWL-1)=IPTI - IWL(JWL) =IPL2 - 64 CONTINUE - NL0=NLN - NLT3=NLNT3 - NLF=JWL/2 - IF(NLF.EQ.0) GO TO 79 -C - IMPROVES TRIANGULATION. - 70 NTT3P3=NTT3+3 - DO 78 IREP=1,NREP - DO 76 ILF=1,NLF - ILFT2=ILF*2 - IPL1=IWL(ILFT2-1) - IPL2=IWL(ILFT2) -C - - LOCATES IN THE IPT ARRAY TWO TRIANGLES ON BOTH SIDES OF -C - - THE FLAGGED LINE SEGMENT. - NTF=0 - DO 71 ITT3R=3,NTT3,3 - ITT3=NTT3P3-ITT3R - IPT1=IPT(ITT3-2) - IPT2=IPT(ITT3-1) - IPT3=IPT(ITT3) - IF(IPL1.NE.IPT1.AND.IPL1.NE.IPT2.AND. - 1 IPL1.NE.IPT3) GO TO 71 - IF(IPL2.NE.IPT1.AND.IPL2.NE.IPT2.AND. - 1 IPL2.NE.IPT3) GO TO 71 - NTF=NTF+1 - ITF(NTF)=ITT3/3 - IF(NTF.EQ.2) GO TO 72 - 71 CONTINUE - IF(NTF.LT.2) GO TO 76 -C - - DETERMINES THE VERTEXES OF THE TRIANGLES THAT DO NOT LIE -C - - ON THE LINE SEGMENT. - 72 IT1T3=ITF(1)*3 - IPTI1=IPT(IT1T3-2) - IF(IPTI1.NE.IPL1.AND.IPTI1.NE.IPL2) GO TO 73 - IPTI1=IPT(IT1T3-1) - IF(IPTI1.NE.IPL1.AND.IPTI1.NE.IPL2) GO TO 73 - IPTI1=IPT(IT1T3) - 73 IT2T3=ITF(2)*3 - IPTI2=IPT(IT2T3-2) - IF(IPTI2.NE.IPL1.AND.IPTI2.NE.IPL2) GO TO 74 - IPTI2=IPT(IT2T3-1) - IF(IPTI2.NE.IPL1.AND.IPTI2.NE.IPL2) GO TO 74 - IPTI2=IPT(IT2T3) -C - - CHECKS IF THE EXCHANGE IS NECESSARY. - 74 IF(IDXCHG(XD,YD,NDP,IPTI1,IPTI2,IPL1,IPL2).EQ.0) - 1 GO TO 76 -C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. - IPT(IT1T3-2)=IPTI1 - IPT(IT1T3-1)=IPTI2 - IPT(IT1T3) =IPL1 - IPT(IT2T3-2)=IPTI2 - IPT(IT2T3-1)=IPTI1 - IPT(IT2T3) =IPL2 -C - - SETS NEW FLAGS. - JWL=JWL+8 - IWL(JWL-7)=IPL1 - IWL(JWL-6)=IPTI1 - IWL(JWL-5)=IPTI1 - IWL(JWL-4)=IPL2 - IWL(JWL-3)=IPL2 - IWL(JWL-2)=IPTI2 - IWL(JWL-1)=IPTI2 - IWL(JWL) =IPL1 - DO 75 JLT3=3,NLT3,3 - IPLJ1=IPL(JLT3-2) - IPLJ2=IPL(JLT3-1) - IF((IPLJ1.EQ.IPL1.AND.IPLJ2.EQ.IPTI2).OR. - 1 (IPLJ2.EQ.IPL1.AND.IPLJ1.EQ.IPTI2)) - 2 IPL(JLT3)=ITF(1) - IF((IPLJ1.EQ.IPL2.AND.IPLJ2.EQ.IPTI1).OR. - 1 (IPLJ2.EQ.IPL2.AND.IPLJ1.EQ.IPTI1)) - 2 IPL(JLT3)=ITF(2) - 75 CONTINUE - 76 CONTINUE - NLFC=NLF - NLF=JWL/2 - IF(NLF.EQ.NLFC) GO TO 79 -C - - RESETS THE IWL ARRAY FOR THE NEXT ROUND. - JWL=0 - JWL1MN=(NLFC+1)*2 - NLFT2=NLF*2 - DO 77 JWL1=JWL1MN,NLFT2,2 - JWL=JWL+2 - IWL(JWL-1)=IWL(JWL1-1) - IWL(JWL) =IWL(JWL1) - 77 CONTINUE - NLF=JWL/2 - 78 CONTINUE - 79 CONTINUE -C REARRANGES THE IPT ARRAY SO THAT THE VERTEXES OF EACH TRIANGLE -C ARE LISTED COUNTER-CLOCKWISE. - 80 DO 81 ITT3=3,NTT3,3 - IP1=IPT(ITT3-2) - IP2=IPT(ITT3-1) - IP3=IPT(ITT3) - IF(SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) - 1 .GE.0.0) GO TO 81 - IPT(ITT3-2)=IP2 - IPT(ITT3-1)=IP1 - 81 CONTINUE - NT=NT0 - NL=NL0 - RETURN -C ERROR EXIT - 90 CONTINUE -C WRITE (LUN,2090) NDP0 - GO TO 93 - 91 CONTINUE -C WRITE (LUN,2091) NDP0,IP1,IP2,X1,Y1 - GO TO 93 - 92 CONTINUE -C WRITE (LUN,2092) NDP0 - 93 CONTINUE -C WRITE (LUN,2093) - NT=0 - RETURN -C FORMAT STATEMENTS - 2090 FORMAT(1X/23H *** NDP LESS THAN 4./8H NDP =,I5) - 2091 FORMAT(1X/29H *** IDENTICAL DATA POINTS./ - 1 8H NDP =,I5,5X,5HIP1 =,I5,5X,5HIP2 =,I5, - 2 5X,4HXD =,E12.4,5X,4HYD =,E12.4) - 2092 FORMAT(1X/33H *** ALL COLLINEAR DATA POINTS./ - 1 8H NDP =,I5) - 2093 FORMAT(35H ERROR DETECTED IN ROUTINE IDTANG/) - END diff --git a/src/idxchg.f b/src/idxchg.f deleted file mode 100644 index c857fffb5cd093b00e8f25130ed330d9c57906c0..0000000000000000000000000000000000000000 --- a/src/idxchg.f +++ /dev/null @@ -1,48 +0,0 @@ - - FUNCTION IDXCHG(X,Y,NDP,I1,I2,I3,I4) ID018560 -C THIS FUNCTION DETERMINES WHETHER OR NOT THE EXCHANGE OF TWO -C TRIANGLES IS NECESSARY ON THE BASIS OF MAX-MIN-ANGLE CRITERION -C BY C. L. LAWSON. -C THE INPUT PARAMETERS ARE -C X,Y = ARRAYS CONTAINING THE COORDINATES OF THE DATA -C POINTS, -C I1,I2,I3,I4 = POINT NUMBERS OF FOUR POINTS P1, P2, -C P3, AND P4 THAT FORM A QUADRILATERAL WITH P3 -C AND P4 CONNECTED DIAGONALLY. -C THIS FUNCTION RETURNS AN INTEGER VALUE 1 (ONE) WHEN AN EX- -C CHANGE IS NECESSARY, AND 0 (ZERO) OTHERWISE. -C DECLARATION STATEMENTS - IMPLICIT DOUBLE PRECISION (A-D,P-Z) - DIMENSION X(NDP),Y(NDP) - EQUIVALENCE (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ), - 1 (A4SQ,B1SQ),(B4SQ,A2SQ),(C4SQ,C3SQ) -C PRELIMINARY PROCESSING - 10 X1=X(I1) - Y1=Y(I1) - X2=X(I2) - Y2=Y(I2) - X3=X(I3) - Y3=Y(I3) - X4=X(I4) - Y4=Y(I4) -C CALCULATION - 20 IDX=0 - U3=(Y2-Y3)*(X1-X3)-(X2-X3)*(Y1-Y3) - U4=(Y1-Y4)*(X2-X4)-(X1-X4)*(Y2-Y4) - IF(U3*U4.LE.0.0) GO TO 30 - U1=(Y3-Y1)*(X4-X1)-(X3-X1)*(Y4-Y1) - U2=(Y4-Y2)*(X3-X2)-(X4-X2)*(Y3-Y2) - A1SQ=(X1-X3)**2+(Y1-Y3)**2 - B1SQ=(X4-X1)**2+(Y4-Y1)**2 - C1SQ=(X3-X4)**2+(Y3-Y4)**2 - A2SQ=(X2-X4)**2+(Y2-Y4)**2 - B2SQ=(X3-X2)**2+(Y3-Y2)**2 - C3SQ=(X2-X1)**2+(Y2-Y1)**2 - S1SQ=U1*U1/(C1SQ*DMAX1(A1SQ,B1SQ)) - S2SQ=U2*U2/(C2SQ*DMAX1(A2SQ,B2SQ)) - S3SQ=U3*U3/(C3SQ*DMAX1(A3SQ,B3SQ)) - S4SQ=U4*U4/(C4SQ*DMAX1(A4SQ,B4SQ)) - IF(DMIN1(S1SQ,S2SQ).LT.DMIN1(S3SQ,S4SQ)) IDX=1 - 30 IDXCHG=IDX - RETURN - END diff --git a/src/init.c b/src/init.c index 9139666442a945e9a5a36d6c5625ff93c9b691fd..7aa8e79b3a5592b398a2533cd667a980dc16cee5 100644 --- a/src/init.c +++ b/src/init.c @@ -75,7 +75,7 @@ static R_NativePrimitiveArgType rgbi3p_t[12] = { }; /* ACM 761: */ -static R_NativePrimitiveArgType sdbi3p_t[17] = { +static R_NativePrimitiveArgType sdbi3p_t[16] = { INTSXP, /* MD, */ INTSXP, /* NDP, */ REALSXP, /* XD, */ @@ -89,13 +89,12 @@ static R_NativePrimitiveArgType sdbi3p_t[17] = { REALSXP, /* WK, */ INTSXP, /* IWK, */ LGLSXP, /* EXTRPI, */ - INTSXP, /* NEAR, */ - INTSXP, /* NEXT, */ - REALSXP, /* DIST */ - LGLSXP /* LINEAR */ + LGLSXP, /* LINEAR */ + REALSXP, /* HBRMN */ + INTSXP /* NRRTT */ }; -static R_NativePrimitiveArgType sdsf3p_t[18] = { +static R_NativePrimitiveArgType sdsf3p_t[17] = { INTSXP, /* MD, */ INTSXP, /* NDP, */ REALSXP, /* XD, */ @@ -110,10 +109,9 @@ static R_NativePrimitiveArgType sdsf3p_t[18] = { REALSXP, /* WK, */ INTSXP, /* IWK, */ LGLSXP, /* EXTRPI, */ - INTSXP, /* NEAR, */ - INTSXP, /* NEXT, */ - REALSXP, /* DIST */ - LGLSXP /* LINEAR */ + LGLSXP, /* LINEAR */ + REALSXP, /* HBRMN */ + INTSXP /* NRRTT */ }; /* ACM 697: */ @@ -140,7 +138,7 @@ static R_NativePrimitiveArgType intrpl_t[7] = { }; /* A. Gebhardt, no ACM code: */ -static R_NativePrimitiveArgType biliip_t[9] = { +static R_NativePrimitiveArgType biliip_t[10] = { REALSXP, /* X0, */ REALSXP, /* Y0, */ REALSXP, /* Z0, */ @@ -149,19 +147,22 @@ static R_NativePrimitiveArgType biliip_t[9] = { REALSXP, /* Y, */ REALSXP, /* Z, */ INTSXP, /* NX, */ - INTSXP /* NY */ + INTSXP, /* NY */ + INTSXP /* IER */ }; static R_FortranMethodDef fortranMethods[] = { - {"idbvip", (DL_FUNC) &F77_SUB(idbvip), 13, idbvip_t}, /* interpp.old, scheduled for removal */ - {"idsfft", (DL_FUNC) &F77_SUB(idsfft), 14, idsfft_t}, /* interp.old, scheduled for removal */ - {"sdbi3p", (DL_FUNC) &F77_SUB(sdbi3p), 17, sdbi3p_t}, /* interpp */ - {"sdsf3p", (DL_FUNC) &F77_SUB(sdsf3p), 18, sdsf3p_t}, /* interp */ + /* {"idbvip", (DL_FUNC) &F77_SUB(idbvip), 13, idbvip_t}, interpp.old, + removed in version 0.6-3 */ + /* {"idsfft", (DL_FUNC) &F77_SUB(idsfft), 14, idsfft_t}, interp.old, + removed in version 0.6-3 */ + {"sdbi3p", (DL_FUNC) &F77_SUB(sdbi3p), 16, sdbi3p_t}, /* interpp */ + {"sdsf3p", (DL_FUNC) &F77_SUB(sdsf3p), 17, sdsf3p_t}, /* interp */ {"uvip3p", (DL_FUNC) &F77_SUB(uvip3p), 8, uvip3p_t}, /* aspline */ {"intrpl", (DL_FUNC) &F77_SUB(intrpl), 7, intrpl_t}, /* aspline */ {"rgbi3p", (DL_FUNC) &F77_SUB(rgbi3p), 12, rgbi3p_t}, /* bicubic */ - {"biliip", (DL_FUNC) &F77_SUB(biliip), 9, biliip_t}, /* bilinear */ + {"biliip", (DL_FUNC) &F77_SUB(biliip), 10, biliip_t}, /* bilinear */ {NULL, NULL, 0} }; diff --git a/src/tripack.f b/src/tripack.f index 4a8fad0aac8218dedf5ac9f06c4abf5118be6815..337dc97b634c870e043f3e346623a7b84bbf5551 100644 --- a/src/tripack.f +++ b/src/tripack.f @@ -1,16 +1,8 @@ -C ALGORITHM 751, COLLECTED ALGORITHMS FROM ACM. -C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, -C VOL. 22, NO. 1, March, 1996, P. 1--8. -C ####### With remark from renka (to appear) 4/dec/1998 -C -C modifications for R: -C REAL -> DOUBLE PRECISION albrecht.gebhardt@uni-klu.ac.at -C SUBROUTINE ADDCST (NCC,LCC,N,X,Y, LWK,IWK,LIST,LPTR, . LEND, IER) INTEGER NCC, LCC(*), N, LWK, IWK(LWK), LIST(*), . LPTR(*), LEND(N), IER - DOUBLE PRECISION X(N), Y(N) + DOUBLE PRECISION X(N), Y(N) C C*********************************************************** C @@ -18,7 +10,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 11/12/94 C C This subroutine provides for creation of a constrained @@ -58,7 +50,7 @@ C C The algorithm is as follows: given a triangulation C which includes one or more sets of constraint nodes, the C corresponding adjacencies (constraint arcs) are forced to -C be present (Subroutine EDGE). Any additional new arcs +C be present (subroutine EDGE). Any additional new arcs C required are chosen to be locally optimal (satisfy the C modified circumcircle property). C @@ -96,10 +88,10 @@ C intersect a constraint arc to be added. NI C is bounded by N-3. C C IWK = Integer work array of length LWK (used by -C Subroutine EDGE to add constraint arcs). +C subroutine EDGE to add constraint arcs). C C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C On output: @@ -110,7 +102,7 @@ C from its input value. C C IWK = Array containing the endpoint indexes of the C new arcs which were swapped in by the last -C call to Subroutine EDGE. +C call to subroutine EDGE. C C LIST,LPTR,LEND = Triangulation data structure with C all constraint arcs present unless @@ -251,7 +243,7 @@ C . LPTR,LEND,LNEW, IER) INTEGER K, IST, NCC, LCC(*), N, LIST(*), LPTR(*), . LEND(*), LNEW, IER - DOUBLE PRECISION XK, YK, X(*), Y(*) + DOUBLE PRECISION XK, YK, X(*), Y(*) C C*********************************************************** C @@ -259,11 +251,11 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/27/98 +C (817) 565-2767 +C 08/25/91 C C Given a triangulation of N nodes in the plane created by -C Subroutine TRMESH or TRMSHR, this subroutine updates the +C subroutine TRMESH or TRMSHR, this subroutine updates the C data structure with the addition of a new node in position C K. If node K is inserted into X and Y (K .LE. N) rather C than appended (K = N+1), then a corresponding insertion @@ -274,7 +266,7 @@ C value: set Z(I+1) to Z(I) for I = N,N-1,...,K. For C optimal efficiency, new nodes should be appended whenever C possible. Insertion is necessary, however, to add a non- C constraint node when constraints are present (refer to -C Subroutine ADDCST). +C subroutine ADDCST). C C Note that a constraint node cannot be added by this C routine. In order to insert a constraint node, it is @@ -315,7 +307,7 @@ C The above parameters are not altered by this routine. C C LCC = List of constraint curve starting indexes (or C dummy array of length 1 if NCC = 0). Refer to -C Subroutine ADDCST. +C subroutine ADDCST. C C N = Number of nodes in the triangulation before K is C added. N .GE. 3. Note that N will be incre- @@ -336,21 +328,20 @@ C On output: C C LCC = List of constraint curve starting indexes in- C cremented by 1 to reflect the insertion of K -C unless NCC = 0 or (IER .NE. 0 and IER .NE. -C -4). +C unless NCC = 0 or IER .NE. 0. C C N = Number of nodes in the triangulation including K -C unless IER .NE. 0 and IER .NE. -4. Note that -C all comments refer to the input value of N. +C unless IER .NE. 0. Note that all comments refer +C to the input value of N. C C X,Y = Arrays updated with the insertion of XK and YK C in the K-th positions (node I+1 was node I be- C fore the insertion for I = K to N if K .LE. N) -C unless IER .NE. 0 and IER .NE. -4. +C unless IER .NE. 0. C C LIST,LPTR,LEND,LNEW = Data structure updated with C the addition of node K unless -C IER .NE. 0 and IER .NE. -4. +C IER .NE. 0. C C IER = Error indicator: C IER = 0 if no errors were encountered. @@ -360,17 +351,14 @@ C IER = -2 if all nodes (including K) are col- C linear. C IER = L if nodes L and K coincide for some L. C IER = -3 if K lies in a constraint region. -C IER = -4 if an error flag is returned by SWAP -C implying that the triangulation -C (geometry) was bad on input. C C The errors conditions are tested in the order C specified. C C Modules required by ADDNOD: BDYADD, CRTRI, INDXCC, -C INSERT, INTADD, JRAND, -C LEFT, LSTPTR, SWAP, -C SWPTST, TRFIND +C INSERT, INTADD, LEFT, +C LSTPTR, SWAP, SWPTST, +C TRFIND C C Intrinsic function called by ADDNOD: ABS C @@ -397,7 +385,7 @@ C Find a triangle (I1,I2,I3) containing K or the rightmost C (I1) and leftmost (I2) visible boundary nodes as viewed C from node K. C - CALL TRFIND (IST,XK,YK,N,X,Y,LIST,LPTR,LEND, I1,I2,I3) + CALL TRFIND (IST,XK,YK,X,Y,LIST,LPTR,LEND, I1,I2,I3) C C Test for collinear nodes, duplicate nodes, and K lying in C a constraint region. @@ -475,28 +463,27 @@ C C Begin loop: find the node opposite K. C 5 LP = LSTPTR(LEND(IO1),IO2,LIST,LPTR) - IF (LIST(LP) .LT. 0) GO TO 6 - LP = LPTR(LP) - IN1 = ABS(LIST(LP)) - IF ( CRTRI(NCC,LCC,IO1,IO2,IN1) ) GO TO 6 + IF (LIST(LP) .LT. 0) GO TO 6 + LP = LPTR(LP) + IN1 = ABS(LIST(LP)) + IF ( CRTRI(NCC,LCC,IO1,IO2,IN1) ) GO TO 6 C C Swap test: if a swap occurs, two new arcs are C opposite K and must be tested. C - IF ( .NOT. SWPTST(IN1,KK,IO1,IO2,X,Y) ) GO TO 6 - CALL SWAP (IN1,KK,IO1,IO2, LIST,LPTR,LEND, LPO1) - IF (LPO1 .EQ. 0) GO TO 11 - IO1 = IN1 - GO TO 5 + IF ( .NOT. SWPTST(IN1,KK,IO1,IO2,X,Y) ) GO TO 6 + CALL SWAP (IN1,KK,IO1,IO2, LIST,LPTR,LEND, LPO1) + IO1 = IN1 + GO TO 5 C C No swap occurred. Test for termination and reset C IO2 and IO1. C - 6 IF (LPO1 .EQ. LPF .OR. LIST(LPO1) .LT. 0) RETURN - IO2 = IO1 - LPO1 = LPTR(LPO1) - IO1 = ABS(LIST(LPO1)) - GO TO 5 + 6 IF (LPO1 .EQ. LPF .OR. LIST(LPO1) .LT. 0) RETURN + IO2 = IO1 + LPO1 = LPTR(LPO1) + IO1 = ABS(LIST(LPO1)) + GO TO 5 C C A parameter is outside its valid range on input. C @@ -517,15 +504,10 @@ C Node K lies in a constraint region. C 10 IER = -3 RETURN -C -C Zero pointer returned by SWAP. -C - 11 IER = -4 - RETURN END DOUBLE PRECISION FUNCTION AREAP (X,Y,NB,NODES) INTEGER NB, NODES(NB) - DOUBLE PRECISION X(*), Y(*) + DOUBLE PRECISION X(*), Y(*) C C*********************************************************** C @@ -533,7 +515,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/21/90 C C Given a sequence of NB points in the plane, this func- @@ -546,7 +528,7 @@ C of the curve is taken to be the first point specified, and C this point should therefore not be specified twice. C C The area of a triangulation may be computed by calling -C AREAP with values of NB and NODES determined by Subroutine +C AREAP with values of NB and NODES determined by subroutine C BNODES. C C @@ -574,7 +556,7 @@ C C*********************************************************** C INTEGER I, ND1, ND2, NNB - DOUBLE PRECISION A + DOUBLE PRECISION A C C Local parameters: C @@ -613,7 +595,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 02/22/91 C C This subroutine adds a boundary node to a triangulation @@ -635,7 +617,7 @@ C arcs. C C I2 = Last (leftmost) boundary node which is visible C from node KK. I1 and I2 may be determined by -C Subroutine TRFIND. +C subroutine TRFIND. C C The above parameters are not altered by this routine. C @@ -716,7 +698,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/01/88 C C Given a triangulation of N points in the plane, this @@ -730,7 +712,7 @@ C C N = Number of nodes in the triangulation. N .GE. 3. C C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C The above parameters are not altered by this routine. @@ -788,8 +770,7 @@ C SUBROUTINE CIRCUM (X1,Y1,X2,Y2,X3,Y3,RATIO, XC,YC,CR, . SA,AR) LOGICAL RATIO - DOUBLE PRECISION X1, Y1, X2, Y2, X3, Y3, XC, YC, CR, - . SA, AR + DOUBLE PRECISION X1, Y1, X2, Y2, X3, Y3, XC, YC, CR, SA, AR C C*********************************************************** C @@ -797,7 +778,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 12/10/96 C C Given three vertices defining a triangle, this subrou- @@ -846,7 +827,7 @@ C C*********************************************************** C INTEGER I - DOUBLE PRECISION DS(3), FX, FY, U(3), V(3) + DOUBLE PRECISION DS(3), FX, FY, U(3), V(3) C C Set U(K) and V(K) to the x and y components, respectively, C of the directed edge opposite vertex K. @@ -904,7 +885,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 08/14/91 C C This function returns TRUE if and only if triangle (I1, @@ -913,7 +894,7 @@ C C C On input: C -C NCC,LCC = Constraint data structure. Refer to Sub- +C NCC,LCC = Constraint data structure. Refer to sub- C routine ADDCST. C C I1,I2,I3 = Nodal indexes of the counterclockwise- @@ -969,14 +950,14 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 11/12/94 C C This subroutine deletes a boundary arc from a triangula- C tion. It may be used to remove a null triangle from the C convex hull boundary. Note, however, that if the union of -C triangles is rendered nonconvex, Subroutines DELNOD, EDGE, -C and TRFIND may fail. Thus, Subroutines ADDCST, ADDNOD, +C triangles is rendered nonconvex, subroutines DELNOD, EDGE, +C and TRFIND may fail. Thus, subroutines ADDCST, ADDNOD, C DELNOD, EDGE, and NEARND should not be called following C an arc deletion. C @@ -1099,8 +1080,8 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 07/30/98 +C (817) 565-2767 +C 08/16/91 C C This subroutine deletes a neighbor NB from the adjacency C list of node N0 (but N0 is not deleted from the adjacency @@ -1131,7 +1112,7 @@ C C LIST,LPTR,LEND,LNEW = Data structure updated with C the removal of NB from the ad- C jacency list of N0 unless -C LPH < 0. +C IER = 1 or IER = 2. C C LPH = List pointer to the hole (NB as a neighbor of C N0) filled in by the values at LNEW-1 or error @@ -1148,17 +1129,6 @@ C C*********************************************************** C INTEGER I, LNW, LP, LPB, LPL, LPP, NN -C -C Local parameters: -C -C I = DO-loop index -C LNW = LNEW-1 (output value of LNEW) -C LP = LIST pointer of the last neighbor of NB -C LPB = Pointer to NB as a neighbor of N0 -C LPL = Pointer to the last neighbor of N0 -C LPP = Pointer to the neighbor of N0 that precedes NB -C NN = Local copy of N -C NN = N C C Test for error 1. @@ -1223,15 +1193,16 @@ C ENDIF 4 CONTINUE C - 5 DO 6 I = 1,LNW-1 + 5 DO 6 I = LNW-1,1,-1 IF (LPTR(I) .EQ. LNW) THEN LPTR(I) = LPB + GO TO 7 ENDIF 6 CONTINUE C C No errors encountered. C - LNEW = LNW + 7 LNEW = LNW LPH = LPB RETURN END @@ -1239,7 +1210,7 @@ C . LNEW,LWK,IWK, IER) INTEGER K, NCC, LCC(*), N, LIST(*), LPTR(*), . LEND(*), LNEW, LWK, IWK(2,*), IER - DOUBLE PRECISION X(*), Y(*) + DOUBLE PRECISION X(*), Y(*) C C*********************************************************** C @@ -1247,22 +1218,22 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/28/98 +C (817) 565-2767 +C 08/22/91 C C This subroutine deletes node K (along with all arcs C incident on node K) from a triangulation of N nodes in the C plane, and inserts arcs as necessary to produce a triangu- C lation of the remaining N-1 nodes. If a Delaunay triangu- C lation is input, a Delaunay triangulation will result, and -C thus, DELNOD reverses the effect of a call to Subroutine +C thus, DELNOD reverses the effect of a call to subroutine C ADDNOD. C C Note that a constraint node cannot be deleted by this C routine. In order to delete a constraint node, it is C necessary to call this routine with NCC = 0, decrement the C appropriate LCC entries (LCC(I) such that LCC(I) > K), and -C then create (or restore) the constraints by a call to Sub- +C then create (or restore) the constraints by a call to sub- C routine ADDCST. C C @@ -1277,7 +1248,7 @@ C The above parameters are not altered by this routine. C C LCC = List of constraint curve starting indexes (or C dummy array of length 1 if NCC = 0). Refer to -C Subroutine ADDCST. +C subroutine ADDCST. C C N = Number of nodes in the triangulation on input. C N .GE. 4. Note that N will be decremented @@ -1288,7 +1259,7 @@ C of the nodes with non-constraint nodes in the C first LCC(1)-1 locations if NCC > 0. C C LIST,LPTR,LEND,LNEW = Data structure defining the -C triangulation. Refer to Sub- +C triangulation. Refer to sub- C routine TRMESH. C C LWK = Number of columns reserved for IWK. LWK must @@ -1347,8 +1318,7 @@ C floating point errors with collinear C nodes or by an invalid data structure. C IER = 5 if an error flag was returned by C OPTIM. An error message is written -C to the standard output unit in this -C event. +C to logical unit 6 in this event. C C Note that the deletion may result in all remaining nodes C being collinear. This situation is not flagged. @@ -1366,7 +1336,7 @@ C . LPH, LPL, LPL2, LPN, LWKL, N1, N2, NFRST, NIT, . NL, NN, NNB, NR LOGICAL BDRY - DOUBLE PRECISION X1, X2, XL, XR, Y1, Y2, YL, YR + DOUBLE PRECISION X1, X2, XL, XR, Y1, Y2, YL, YR C C Set N1 to K and NNB to the number of neighbors of N1 (plus C one if N1 is a boundary node), and test for errors. LPF @@ -1557,7 +1527,10 @@ C 10 CONTINUE C 11 DO 12 I = LNW-1,1,-1 - IF (LPTR(I) .EQ. LNW) LPTR(I) = LP + IF (LPTR(I) .EQ. LNW) THEN + LPTR(I) = LP + GO TO 13 + ENDIF 12 CONTINUE 13 CONTINUE C @@ -1574,7 +1547,7 @@ C N = NN LNEW = LNW IF (IWL .GT. 0) THEN - NIT = 4*IWL + NIT = 3*IWL CALL OPTIM (X,Y,IWL, LIST,LPTR,LEND,NIT,IWK, IERR) IF (IERR .NE. 0) GO TO 25 ENDIF @@ -1609,7 +1582,7 @@ C C Error flag returned by OPTIM. C 25 IER = 5 -C WRITE (*,100) NIT, IERR +c WRITE (6,100) NIT, IERR RETURN 100 FORMAT (//5X,'*** Error in OPTIM: NIT = ',I4, . ', IER = ',I1,' ***'/) @@ -1618,7 +1591,7 @@ C WRITE (*,100) NIT, IERR . LEND, IER) INTEGER IN1, IN2, LWK, IWK(2,*), LIST(*), LPTR(*), . LEND(*), IER - DOUBLE PRECISION X(*), Y(*) + DOUBLE PRECISION X(*), Y(*) C C*********************************************************** C @@ -1626,8 +1599,8 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/23/98 +C (817) 565-2767 +C 08/01/90 C C Given a triangulation of N nodes and a pair of nodal C indexes IN1 and IN2, this routine swaps arcs as necessary @@ -1639,9 +1612,9 @@ C all arcs other than IN1-IN2 are locally optimal. C C A sequence of calls to EDGE may be used to force the C presence of a set of edges defining the boundary of a non- -C convex and/or multiply connected region (refer to Subrou- +C convex and/or multiply connected region (refer to subrou- C tine ADDCST), or to introduce barriers into the triangula- -C tion. Note that Subroutine GETNP will not necessarily +C tion. Note that subroutine GETNP will not necessarily C return closest nodes if the triangulation has been con- C strained by a call to EDGE. However, this is appropriate C in some applications, such as triangle-based interpolation @@ -1666,7 +1639,7 @@ C C IWK = Integer work array of length at least 2*LWK. C C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C On output: @@ -1703,8 +1676,8 @@ C point error). C IER = 4 if an error flag was returned by C OPTIM. C -C An error message is written to the standard output unit -C in the case of IER = 3 or IER = 4. +C An error message is written to logical unit 6 in the +C case of IER = 3 or IER = 4. C C Modules required by EDGE: LEFT, LSTPTR, OPTIM, SWAP, C SWPTST @@ -1717,13 +1690,13 @@ C INTEGER I, IERR, IWC, IWCP1, IWEND, IWF, IWL, LFT, LP, . LPL, LP21, NEXT, NIT, NL, NR, N0, N1, N2, . N1FRST, N1LST - DOUBLE PRECISION DX, DY, X0, Y0, X1, Y1, X2, Y2 + DOUBLE PRECISION DX, DY, X0, Y0, X1, Y1, X2, Y2 C C Local parameters: C C DX,DY = Components of arc N1-N2 C I = DO-loop index and column index for IWK -C IERR = Error flag returned by Subroutine OPTIM +C IERR = Error flag returned by subroutine OPTIM C IWC = IWK index between IWF and IWL -- NL->NR is C stored in IWK(1,IWC)->IWK(2,IWC) C IWCP1 = IWC + 1 @@ -2105,7 +2078,7 @@ C Invalid triangulation data structure or collinear nodes C on convex hull boundary. C 33 IER = 3 -C WRITE (*,130) IN1, IN2 +c WRITE (6,130) IN1, IN2 130 FORMAT (//5X,'*** Error in EDGE: Invalid triangula', . 'tion or null triangles on boundary'/ . 9X,'IN1 =',I4,', IN2=',I4/) @@ -2114,7 +2087,7 @@ C C Error flag returned by OPTIM. C 34 IER = 4 -C WRITE (*,140) NIT, IERR +c WRITE (6,140) NIT, IERR 140 FORMAT (//5X,'*** Error in OPTIM: NIT = ',I4, . ', IER = ',I1,' ***'/) RETURN @@ -2123,7 +2096,7 @@ C WRITE (*,140) NIT, IERR . L, NPTS,DS, IER) INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N), . L, NPTS(L), IER - DOUBLE PRECISION X(N), Y(N), DS(L) + DOUBLE PRECISION X(N), Y(N), DS(L) C C*********************************************************** C @@ -2131,7 +2104,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 11/12/94 C C Given a triangulation of N nodes and an array NPTS con- @@ -2174,7 +2147,7 @@ C NCC = Number of constraints. NCC .GE. 0. C C LCC = List of constraint curve starting indexes (or C dummy array of length 1 if NCC = 0). Refer to -C Subroutine ADDCST. +C subroutine ADDCST. C C N = Number of nodes in the triangulation. N .GE. 3. C @@ -2183,7 +2156,7 @@ C of the nodes with non-constraint nodes in the C first LCC(1)-1 locations if NCC > 0. C C LIST,LPTR,LEND = Triangulation data structure. Re- -C fer to Subroutine TRMESH. +C fer to subroutine TRMESH. C C L = Number of nodes in the sequence on output. 2 C .LE. L .LE. N. @@ -2228,8 +2201,7 @@ C . NKBAK, NKFOR, NL, NN LOGICAL ISW, VIS, NCF, NJF, SKIP, SKSAV, LFT1, LFT2, . LFT12 - DOUBLE PRECISION DC, DL, X1, XC, XJ, XK, Y1, YC, YJ, - . YK + DOUBLE PRECISION DC, DL, X1, XC, XJ, XK, Y1, YC, YJ, YK C C Store parameters in local variables and test for errors. C LCC1 indexes the first constraint node. @@ -2496,7 +2468,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 08/25/91 C C Given a constrained Delaunay triangulation, this func- @@ -2516,12 +2488,12 @@ C NCC = Number of constraints. NCC .GE. 0. C C LCC = List of constraint curve starting indexes (or C dummy array of length 1 if NCC = 0). Refer to -C Subroutine ADDCST. +C subroutine ADDCST. C C N = Number of nodes in the triangulation. N .GE. 3. C C LIST,LEND = Data structure defining the triangula- -C tion. Refer to Subroutine TRMESH. +C tion. Refer to subroutine TRMESH. C C Input parameters are not altered by this function. Note C that the parameters are not tested for validity. @@ -2588,7 +2560,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/01/88 C C This subroutine inserts K as a neighbor of N1 following @@ -2606,7 +2578,7 @@ C C The above parameters are not altered by this routine. C C LIST,LPTR,LNEW = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C On output: @@ -2637,7 +2609,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 02/22/91 C C This subroutine adds an interior node to a triangulation @@ -2659,7 +2631,7 @@ C C The above parameters are not altered by this routine. C C LIST,LPTR,LEND,LNEW = Data structure defining the -C triangulation. Refer to Sub- +C triangulation. Refer to sub- C routine TRMESH. Triangle C (I1,I2,I3) must be included C in the triangulation. @@ -2715,7 +2687,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/01/88 C C Given a pair of line segments P1-P2 and P3-P4, this @@ -2749,8 +2721,7 @@ C Modules required by INTSEC: None C C*********************************************************** C - DOUBLE PRECISION A, B, D, DX12, DX31, DX34, DY12, - . DY31, DY34 + DOUBLE PRECISION A, B, D, DX12, DX31, DX34, DY12, DY31, DY34 C C Test for overlap between the smallest rectangles that C contain the line segments and have sides parallel to @@ -2794,74 +2765,10 @@ C D .EQ. 0 and thus either the line segments are parallel, C or one (or both) of them is a single point. C 1 INTSEC = A .EQ. 0. .AND. B .EQ. 0. - RETURN - END - INTEGER FUNCTION JRAND (N, IX,IY,IZ ) - INTEGER N, IX, IY, IZ -C -C*********************************************************** -C -C From STRIPACK -C Robert J. Renka -C Dept. of Computer Science -C Univ. of North Texas -C renka@cs.unt.edu -C 07/28/98 -C -C This function returns a uniformly distributed pseudo- -C random integer in the range 1 to N. -C -C -C On input: -C -C N = Maximum value to be returned. -C -C N is not altered by this function. -C -C IX,IY,IZ = Integer seeds initialized to values in -C the range 1 to 30,000 before the first -C call to JRAND, and not altered between -C subsequent calls (unless a sequence of -C random numbers is to be repeated by -C reinitializing the seeds). -C -C On output: -C -C IX,IY,IZ = Updated integer seeds. -C -C JRAND = Random integer in the range 1 to N. -C -C Reference: B. A. Wichmann and I. D. Hill, "An Efficient -C and Portable Pseudo-random Number Generator", -C Applied Statistics, Vol. 31, No. 2, 1982, -C pp. 188-190. -C -C Modules required by JRAND: None -C -C Intrinsic functions called by JRAND: INT, MOD, DBLE -C -C*********************************************************** -C - DOUBLE PRECISION U, X -C -C Local parameters: -C -C U = Pseudo-random number uniformly distributed in the -C interval (0,1). -C X = Pseudo-random number in the range 0 to 3 whose frac- -C tional part is U. -C - IX = MOD(171*IX,30269) - IY = MOD(172*IY,30307) - IZ = MOD(170*IZ,30323) - X = (DBLE(IX)/30269.) + (DBLE(IY)/30307.) + - . (DBLE(IZ)/30323.) - U = X - INT(X) - JRAND = DBLE(N)*U + 1. RETURN END LOGICAL FUNCTION LEFT (X1,Y1,X2,Y2,X0,Y0) - DOUBLE PRECISION X1, Y1, X2, Y2, X0, Y0 + DOUBLE PRECISION X1, Y1, X2, Y2, X0, Y0 C C*********************************************************** C @@ -2869,7 +2776,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/01/88 C C This function determines whether node N0 is to the left @@ -2925,7 +2832,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/01/88 C C This function returns the index (LIST pointer) of NB in @@ -2940,7 +2847,7 @@ C NB = Index of the node whose pointer is to be re- C turned. NB must be connected to N0. C C LIST,LPTR = Data structure defining the triangula- -C tion. Refer to Subroutine TRMESH. +C tion. Refer to subroutine TRMESH. C C Input parameters are not altered by this function. C @@ -2974,11 +2881,11 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/01/88 C C This function returns the number of neighbors of a node -C N0 in a triangulation created by Subroutine TRMESH (or +C N0 in a triangulation created by subroutine TRMESH (or C TRMSHR). C C @@ -3015,7 +2922,7 @@ C INTEGER FUNCTION NEARND (XP,YP,IST,N,X,Y,LIST,LPTR, . LEND, DSQ) INTEGER IST, N, LIST(*), LPTR(*), LEND(N) - DOUBLE PRECISION XP, YP, X(N), Y(N), DSQ + DOUBLE PRECISION XP, YP, X(N), Y(N), DSQ C C*********************************************************** C @@ -3023,11 +2930,11 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/27/98 +C (817) 565-2767 +C 10/31/90 C C Given a point P in the plane and a Delaunay triangula- -C tion created by Subroutine TRMESH or TRMSHR, this function +C tion created by subroutine TRMESH or TRMSHR, this function C returns the index of the nearest triangulation node to P. C C The algorithm consists of implicitly adding P to the @@ -3069,7 +2976,7 @@ C Note that the number of candidates for NEARND C (neighbors of P) is limited to LMAX defined in C the PARAMETER statement below. C -C Modules required by NEARND: JRAND, LEFT, LSTPTR, TRFIND +C Modules required by NEARND: LEFT, LSTPTR, TRFIND C C Intrinsic function called by NEARND: ABS C @@ -3079,22 +2986,22 @@ C INTEGER LMAX PARAMETER (LMAX=25) INTEGER I1, I2, I3, L, LISTP(LMAX), LP, LP1, LP2, - . LPL, LPTRP(LMAX), N1, N2, N3, NR, NST - DOUBLE PRECISION COS1, COS2, DS1, DSR, DX11, DX12, - . DX21, DX22, DY11, DY12, DY21, DY22, SIN1, - . SIN2 + . LPL, LPTRP(LMAX), N1, N2, N3, NN, NR, NST + DOUBLE PRECISION COS1, COS2, DS1, DSR, DX11, DX12, DX21, + . DX22, DY11, DY12, DY21, DY22, SIN1, SIN2 C C Store local parameters and test for N invalid. C - IF (N .LT. 3) GO TO 7 + NN = N + IF (NN .LT. 3) GO TO 7 NST = IST - IF (NST .LT. 1 .OR. NST .GT. N) NST = 1 + IF (NST .LT. 1 .OR. NST .GT. NN) NST = 1 C C Find a triangle (I1,I2,I3) containing P, or the rightmost C (I1) and leftmost (I2) visible boundary nodes as viewed C from P. C - CALL TRFIND (NST,XP,YP,N,X,Y,LIST,LPTR,LEND, I1,I2,I3) + CALL TRFIND (NST,XP,YP,X,Y,LIST,LPTR,LEND, I1,I2,I3) C C Test for collinear nodes. C @@ -3223,7 +3130,7 @@ C SUBROUTINE OPTIM (X,Y,NA, LIST,LPTR,LEND,NIT,IWK, IER) INTEGER NA, LIST(*), LPTR(*), LEND(*), NIT, IWK(2,NA), . IER - DOUBLE PRECISION X(*), Y(*) + DOUBLE PRECISION X(*), Y(*) C C*********************************************************** C @@ -3231,8 +3138,8 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/27/98 +C (817) 565-2767 +C 06/14/90 C C Given a set of NA triangulation arcs, this subroutine C optimizes the portion of the triangulation consisting of @@ -3259,7 +3166,7 @@ C C The above parameters are not altered by this routine. C C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C NIT = Maximum number of iterations to be performed. @@ -3291,8 +3198,6 @@ C IER = 3 if IWK(2,I) is not a neighbor of C IWK(1,I) for some I in the range 1 C to NA. A swap may have occurred in C this case. -C IER = 4 if a zero pointer was returned by -C Subroutine SWAP. C C Modules required by OPTIM: LSTPTR, SWAP, SWPTST C @@ -3304,23 +3209,6 @@ C INTEGER I, IO1, IO2, ITER, LP, LP21, LPL, LPP, MAXIT, . N1, N2, NNA LOGICAL SWP -C -C Local parameters: -C -C I = Column index for IWK -C IO1,IO2 = Nodal indexes of the endpoints of an arc in IWK -C ITER = Iteration count -C LP = LIST pointer -C LP21 = Parameter returned by SWAP (not used) -C LPL = Pointer to the last neighbor of IO1 -C LPP = Pointer to the node preceding IO2 as a neighbor -C of IO1 -C MAXIT = Input value of NIT -C N1,N2 = Nodes opposite IO1->IO2 and IO2->IO1, -C respectively -C NNA = Local copy of NA -C SWP = Flag set to TRUE iff a swap occurs in the -C optimization loop C NNA = NA MAXIT = NIT @@ -3346,10 +3234,9 @@ C C C Set N1 and N2 to the nodes opposite IO1->IO2 and C IO2->IO1, respectively. Determine the following: -C -C LPL = pointer to the last neighbor of IO1, -C LP = pointer to IO2 as a neighbor of IO1, and -C LPP = pointer to the node N2 preceding IO2. +C LPL = pointer to the last neighbor of IO1, +C LP = pointer to IO2 as a neighbor of IO1, and +C LPP = pointer to the node N2 preceding IO2. C LPL = LEND(IO1) LPP = LPL @@ -3377,9 +3264,8 @@ C C Test IO1-IO2 for a swap, and update IWK if necessary. C IF ( .NOT. SWPTST(N1,N2,IO1,IO2,X,Y) ) GO TO 4 - CALL SWAP (N1,N2,IO1,IO2, LIST,LPTR,LEND, LP21) - IF (LP21 .EQ. 0) GO TO 9 SWP = .TRUE. + CALL SWAP (N1,N2,IO1,IO2, LIST,LPTR,LEND, LP21) IWK(1,I) = N1 IWK(2,I) = N2 4 CONTINUE @@ -3408,11 +3294,391 @@ C 8 NIT = ITER IER = 3 RETURN + END + SUBROUTINE PERMUT (N,IP, A ) + INTEGER N, IP(N) + DOUBLE PRECISION A(N) C -C Zero pointer returned by SWAP. +C*********************************************************** C - 9 NIT = ITER - IER = 4 +C From TRIPACK +C Robert J. Renka +C Dept. of Computer Science +C Univ. of North Texas +C (817) 565-2767 +C 09/01/88 +C +C This subroutine performs an in-place permutation of a +C vector. +C +C +C On input: +C +C N = Vector length. +C +C IP = Array of length N containing a permutation of +C the integers 1,...,N. +C +C The above parameters are not altered by this routine. +C +C A = Array of length N containing the vector to be +C permuted. +C +C On output: +C +C A = Reordered vector reflecting the permutation +C defined by IP. +C +C Modules required by PERMUT: None +C +C*********************************************************** +C + INTEGER NN, K, J, IPJ + DOUBLE PRECISION TEMP +C +C Local parameters: +C +C NN = Local copy of N +C K = Index for IP and for the first element of A in a +C permutation +C J = Index for IP and A -- J .GE. K +C IPJ = IP(J) +C TEMP = Temporary storage for A(K) +C + NN = N + IF (NN .LT. 2) RETURN + K = 1 +C +C Loop on permutations. +C + 1 J = K + TEMP = A(K) +C +C Apply permutation to A. IP(J) is marked (made negative) +C as being included in the permutation. +C + 2 IPJ = IP(J) + IP(J) = -IPJ + IF (IPJ .EQ. K) GO TO 3 + A(J) = A(IPJ) + J = IPJ + GO TO 2 + 3 A(J) = TEMP +C +C Search for an unmarked element of IP. +C + 4 K = K + 1 + IF (K .GT. NN) GO TO 5 + IF (IP(K) .GT. 0) GO TO 1 + GO TO 4 +C +C All permutations have been applied. Unmark IP. +C + 5 DO 6 K = 1,NN + IP(K) = -IP(K) + 6 CONTINUE + RETURN + END + SUBROUTINE QSORT (N,X, IND) + INTEGER N, IND(N) + DOUBLE PRECISION X(N) +C +C*********************************************************** +C +C From TRIPACK +C Robert J. Renka +C Dept. of Computer Science +C Univ. of North Texas +C (817) 565-2767 +C 09/01/88 +C +C This subroutine uses an order N*LOG(N) quick sort to +C sort the real array X into increasing order. The algor- +C ithm is as follows. IND is initialized to the ordered +C sequence of indexes 1,...,N, and all interchanges are +C applied to IND. X is divided into two portions by picking +C a central element T. The first and last elements are com- +C pared with T, and interchanges are applied as necessary so +C that the three values are in ascending order. Inter- +C changes are then applied so that all elements greater than +C T are in the upper portion of the array and all elements +C less than T are in the lower portion. The upper and lower +C indices of one of the portions are saved in local arrays, +C and the process is repeated recursively on the other +C portion. When a portion is completely sorted, the process +C begins again by retrieving the indexes bounding another +C unsorted portion. +C +C +C On input: +C +C N = Number of elements to be sorted. +C +C X = Array of length N to be sorted. +C +C The above parameters are not altered by this routine. +C +C IND = Array of length at least N. +C +C On output: +C +C IND = Sequence of integers 1,...,N permuted in the +C the same fashion that X would be. Thus, the +C sorted array may be stored in an array Y with +C the assignment statements: Y(I) = X(IND(I)) +C for I = 1 to N. Alternatively, X may be over- +C written with the sorted array by a call to +C subroutine PERMUT. +C +C Modules required by QSORT: None +C +C Intrinsic functions called by QSORT: DBLE, INT +C +C*********************************************************** +C +C NOTE -- IU and IL must be dimensioned .GE. log(N), where +C the log has base 2. +C +C*********************************************************** +C + INTEGER IU(21), IL(21) + INTEGER M, I, J, K, L, IJ, IT, ITT, INDX + DOUBLE PRECISION R, T +C +C Local parameters: +C +C IU,IL = Temporary storage for the upper and lower +C indexes of portions of the array X +C M = Index for IU and IL +C I,J = Lower and upper indexes of a portion of X +C K,L = Indexes in the range I,...,J +C IJ = Randomly chosen index between I and J +C IT,ITT = Temporary storage for interchanges in IND +C INDX = Temporary index for X +C R = Pseudo random number for generating IJ +C T = Central element of X +C + IF (N .LE. 0) RETURN +C +C Initialize IND, M, I, J, and R. +C + DO 1 I = 1,N + IND(I) = I + 1 CONTINUE + M = 1 + I = 1 + J = N + R = .375 +C +C Top of loop -- +C + 2 IF (I .GE. J) GO TO 7 + IF (R .GT. .5898437) THEN + R = R - .21875 + ELSE + R = R + .0390625 + ENDIF +C +C Initialize K. +C + 3 K = I +C +C Select a central element of X and save it in T. +C + IJ = I + INT(R*DBLE(J-I)) + IT = IND(IJ) + T = X(IT) +C +C If the first element of the array is greater than T, +C interchange it with T. +C + INDX = IND(I) + IF (X(INDX) .GT. T) THEN + IND(IJ) = INDX + IND(I) = IT + IT = INDX + T = X(IT) + ENDIF +C +C Initialize L. +C + L = J +C +C If the last element of the array is less than T, +C interchange it with T. +C + INDX = IND(J) + IF (X(INDX) .GE. T) GO TO 5 + IND(IJ) = INDX + IND(J) = IT + IT = INDX + T = X(IT) +C +C If the first element of the array is greater than T, +C interchange it with T. +C + INDX = IND(I) + IF (X(INDX) .LE. T) GO TO 5 + IND(IJ) = INDX + IND(I) = IT + IT = INDX + T = X(IT) + GO TO 5 +C +C Interchange elements K and L. +C + 4 ITT = IND(L) + IND(L) = IND(K) + IND(K) = ITT +C +C Find an element in the upper part of the array which is +C not larger than T. +C + 5 L = L - 1 + INDX = IND(L) + IF (X(INDX) .GT. T) GO TO 5 +C +C Find an element in the lower part of the array which is +C not smaller than T. +C + 6 K = K + 1 + INDX = IND(K) + IF (X(INDX) .LT. T) GO TO 6 +C +C If K .LE. L, interchange elements K and L. +C + IF (K .LE. L) GO TO 4 +C +C Save the upper and lower subscripts of the portion of the +C array yet to be sorted. +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M + 1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M + 1 + ENDIF + GO TO 8 +C +C Begin again on another unsorted portion of the array. +C + 7 M = M - 1 + IF (M .EQ. 0) RETURN + I = IL(M) + J = IU(M) +C + 8 IF (J-I .GE. 11) GO TO 3 + IF (I .EQ. 1) GO TO 2 + I = I - 1 +C +C Sort elements I+1,...,J. Note that 1 .LE. I .LT. J and +C J-I .LT. 11. +C + 9 I = I + 1 + IF (I .EQ. J) GO TO 7 + INDX = IND(I+1) + T = X(INDX) + IT = INDX + INDX = IND(I) + IF (X(INDX) .LE. T) GO TO 9 + K = I +C + 10 IND(K+1) = IND(K) + K = K - 1 + INDX = IND(K) + IF (T .LT. X(INDX)) GO TO 10 + IND(K+1) = IT + GO TO 9 + END + SUBROUTINE REORDR (N,IFLAG, A,B,C, IND) + INTEGER N, IFLAG, IND(N) + DOUBLE PRECISION A(N), B(N), C(N) +C +C*********************************************************** +C +C From TRIPACK +C Robert J. Renka +C Dept. of Computer Science +C Univ. of North Texas +C (817) 565-2767 +C 09/01/88 +C +C This subroutine uses an order N*LOG(N) quick sort to +C reorder the real array A into increasing order. A record +C of the permutations applied to A is stored in IND, and +C these permutations may be applied to one or two additional +C vectors by this routine. Any other vector V may be per- +C muted in the same fashion by calling subroutine PERMUT +C with N, IND, and V as parameters. +C +C A set of nodes (X(I),Y(I)) (along with data values Z(I)) +C may be presorted by REORDR for increases efficiency in the +C triangulation routine TRMESH. Either X or Y may be used +C as the sort key (associated with A). Note, however, that +C constraint nodes must not be reordered -- only the first +C LCC(1)-1 nodes should be sorted. +C +C +C On input: +C +C N = Number of elements in the arrays to be sorted. +C +C IFLAG = Number of arrays to be sorted: +C IFLAG .LE. 0 if A, B, and C are to remain +C unaltered. +C IFLAG .EQ. 1 if only A is to be reordered. +C IFLAG .EQ. 2 if A and B are to be reordered. +C IFLAG .GE. 3 if A, B, and C are to be re- +C ordered. +C +C A,B,C = Arrays of length N to be reordered, or dummy +C arrays of length 1, depending on IFLAG. +C Unless IFLAG .LE. 0, A is sorted into nonde- +C creasing order, and the same permutations +C are applied to any other arrays to be +C reordered. +C +C IND = Integer array of length at least N. +C +C N, IFLAG, and any dummy arrays are not altered by this +C routine. +C +C On output: +C +C A,B,C = Sorted or unaltered arrays. +C +C IND = Sequence of integers 1,...,N permuted in the +C the same fashion as A. Thus, the ordering +C may be applied to a vector V and stored in W +C by setting W(I) = V(IND(I)) for I = 1 to N, +C or V may be reordered in place by a call to +C subroutine PERMUT. +C +C Modules required by REORDR: PERMUT, QSORT +C +C*********************************************************** +C + INTEGER NN, NV +C +C Local parameters: +C +C NN = Local copy of N +C NV = Local copy of IFLAG +C + NN = N + NV = IFLAG + CALL QSORT (NN,A, IND) + IF (NV .LE. 0) RETURN + CALL PERMUT (NN,IND, A ) + IF (NV .EQ. 1) RETURN + CALL PERMUT (NN,IND, B ) + IF (NV .EQ. 2) RETURN + CALL PERMUT (NN,IND, C ) RETURN END DOUBLE PRECISION FUNCTION STORE (X) @@ -3424,7 +3690,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 03/18/90 C C This function forces its argument X to be stored in a @@ -3468,15 +3734,13 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/22/98 +C (817) 565-2767 +C 09/01/88 C -C Given a triangulation of a set of points on the unit -C sphere, this subroutine replaces a diagonal arc in a -C strictly convex quadrilateral (defined by a pair of adja- -C cent triangles) with the other diagonal. Equivalently, a -C pair of adjacent triangles is replaced by another pair -C having the same union. +C Given a triangulation of a set of points in the plane, +C this subroutine replaces a diagonal arc in a strictly +C convex quadrilateral (defined by a pair of adjacent tri- +C angles) with the other diagonal. C C C On input: @@ -3490,7 +3754,7 @@ C C The above parameters are not altered by this routine. C C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C On output: @@ -3498,35 +3762,18 @@ C C LIST,LPTR,LEND = Data structure updated with the C swap -- triangles (IO1,IO2,IN1) and C (IO2,IO1,IN2) are replaced by -C (IN1,IN2,IO2) and (IN2,IN1,IO1) -C unless LP21 = 0. +C (IN1,IN2,IO2) and (IN2,IN1,IO1). C C LP21 = Index of IN1 as a neighbor of IN2 after the -C swap is performed unless IN1 and IN2 are -C adjacent on input, in which case LP21 = 0. +C swap is performed. C C Module required by SWAP: LSTPTR C -C Intrinsic function called by SWAP: ABS -C C*********************************************************** C INTEGER LSTPTR INTEGER LP, LPH, LPSAV C -C Local parameters: -C -C LP,LPH,LPSAV = LIST pointers -C -C -C Test for IN1 and IN2 adjacent. -C - LP = LSTPTR(LEND(IN1),IN2,LIST,LPTR) - IF (ABS(LIST(LP)) .EQ. IN2) THEN - LP21 = 0 - RETURN - ENDIF -C C Delete IO2 as a neighbor of IO1. C LP = LSTPTR(LEND(IO1),IN2,LIST,LPTR) @@ -3570,7 +3817,7 @@ C END LOGICAL FUNCTION SWPTST (IN1,IN2,IO1,IO2,X,Y) INTEGER IN1, IN2, IO1, IO2 - DOUBLE PRECISION X(*), Y(*) + DOUBLE PRECISION X(*), Y(*) C C*********************************************************** C @@ -3578,7 +3825,7 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu +C (817) 565-2767 C 09/01/88 C C This function applies the circumcircle test to a quadri- @@ -3595,7 +3842,7 @@ C C When the four vertices are nearly cocircular (the C neutral case), the preferred decision is no swap -- in C order to avoid unnecessary swaps and, more important, to -C avoid cycling in Subroutine OPTIM which is called by +C avoid cycling in subroutine OPTIM which is called by C DELNOD and EDGE. Thus, a tolerance SWTOL (stored in C SWPCOM by TRMESH or TRMSHR) is used to define 'nearness' C to the neutral case. @@ -3696,10 +3943,10 @@ C 2 SWPTST = .FALSE. RETURN END - SUBROUTINE TRFIND (NST,PX,PY,N,X,Y,LIST,LPTR,LEND, I1, + SUBROUTINE TRFIND (NST,PX,PY,X,Y,LIST,LPTR,LEND, I1, . I2,I3) - INTEGER NST, N, LIST(*), LPTR(*), LEND(N), I1, I2, I3 - DOUBLE PRECISION PX, PY, X(N), Y(N) + INTEGER NST, LIST(*), LPTR(*), LEND(*), I1, I2, I3 + DOUBLE PRECISION PX, PY, X(*), Y(*) C C*********************************************************** C @@ -3707,11 +3954,11 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 07/28/98 +C (817) 565-2767 +C 06/14/90 C C This subroutine locates a point P relative to a triangu- -C lation created by Subroutine TRMESH or TRMSHR. If P is +C lation created by subroutine TRMESH or TRMSHR. If P is C contained in a triangle, the three vertex indexes are C returned. Otherwise, the indexes of the rightmost and C leftmost visible boundary nodes are returned. @@ -3723,16 +3970,14 @@ C NST = Index of a node at which TRFIND begins the C search. Search time depends on the proximity C of this node to P. C -C PX,PY = X and y coordinates of the point P to be +C PX,PY = X and Y coordinates of the point P to be C located. C -C N = Number of nodes in the triangulation. N .GE. 3. -C -C X,Y = Arrays of length N containing the coordinates -C of the nodes in the triangulation. +C X,Y = Arrays containing the coordinates of the nodes +C in the triangulation. C C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C Input parameters are not altered by this routine. @@ -3741,61 +3986,30 @@ C On output: C C I1,I2,I3 = Nodal indexes, in counterclockwise order, C of the vertices of a triangle containing -C P if P is contained in a triangle. If P -C is not in the convex hull of the nodes, -C I1 indexes the rightmost visible boundary -C node, I2 indexes the leftmost visible -C boundary node, and I3 = 0. Rightmost and -C leftmost are defined from the perspective -C of P, and a pair of points are visible -C from each other if and only if the line -C segment joining them intersects no trian- -C gulation arc. If P and all of the nodes -C lie on a common line, then I1 = I2 = I3 = -C 0 on output. -C -C Modules required by TRFIND: JRAND, LEFT, LSTPTR, STORE -C -C Intrinsic function called by TRFIND: ABS +C P, or, if P is not contained in the con- +C vex hull of the nodes, I1 indexes the +C rightmost visible boundary node, I2 in- +C dexes the leftmost visible boundary node, +C and I3 = 0. Rightmost and leftmost are +C defined from the perspective of P, and a +C pair of points are visible from each +C other if and only if the line segment +C joining them intersects no triangulation +C arc. If P and all of the nodes lie on a +C common line, then I1 = I2 = I3 = 0 on +C output. +C +C Modules required by TRFIND: LEFT, LSTPTR +C +C Intrinsic functions called by TRFIND: ABS, MAX C C*********************************************************** C - INTEGER JRAND, LSTPTR + INTEGER LSTPTR LOGICAL LEFT - DOUBLE PRECISION STORE - INTEGER IX, IY, IZ, LP, N0, N1, N1S, N2, N2S, N3, N4, - . NB, NF, NL, NP, NPP + INTEGER LP, N0, N1, N2, N3, N4, NB, NF, NL, NP, NPP LOGICAL FRWRD - DOUBLE PRECISION B1, B2, XA, XB, XC, XP, YA, YB, YC, - . YP -C - SAVE IX, IY, IZ - DATA IX/1/, IY/2/, IZ/3/ -C -C Local parameters: -C -C B1,B2 = Unnormalized barycentric coordinates of P with -C respect to (N1,N2,N3) -C IX,IY,IZ = Integer seeds for JRAND -C LP = LIST pointer -C N0,N1,N2 = Nodes in counterclockwise order defining a -C cone (with vertex N0) containing P -C N1S,N2S = Saved values of N1 and N2 -C N3,N4 = Nodes opposite N1->N2 and N2->N1, respectively -C NB = Index of a boundary node -- first neighbor of -C NF or last neighbor of NL in the boundary -C traversal loops -C NF,NL = First and last neighbors of N0, or first -C (rightmost) and last (leftmost) nodes -C visible from P when P is exterior to the -C triangulation -C NP,NPP = Indexes of boundary nodes used in the boundary -C traversal loops -C XA,XB,XC = Dummy arguments for FRWRD -C YA,YB,YC = Dummy arguments for FRWRD -C XP,YP = Local variables containing the components of P -C -C Statement function: + DOUBLE PRECISION XA, XB, XC, XP, YA, YB, YC, YP C C FRWRD = TRUE iff C is forward of A->B C iff B,A->C> .GE. 0. @@ -3803,16 +4017,11 @@ C FRWRD(XA,YA,XB,YB,XC,YC) = (XB-XA)*(XC-XA) + . (YB-YA)*(YC-YA) .GE. 0. C -C Initialize variables. -C + N0 = MAX(NST,1) XP = PX YP = PY - N0 = NST - IF (N0 .LT. 1 .OR. N0 .GT. N) - . N0 = JRAND(N, IX,IY,IZ ) C -C Set NF and NL to the first and last neighbors of N0, and -C initialize N1 = NF. +C Set N1 = NF and NL to the first and last neighbors of N0. C 1 LP = LEND(N0) NL = LIST(LP) @@ -3820,7 +4029,7 @@ C NF = LIST(LP) N1 = NF C -C Find a pair of adjacent neighbors N1,N2 of N0 that define +C Find a pair of adjacent neighbors N1,N2 of N0 which define C a wedge containing P: P LEFT N0->N1 and P RIGHT N0->N2. C IF (NL .GT. 0) GO TO 2 @@ -3887,12 +4096,9 @@ C C C P is contained in the wedge defined by line segments C N0->N1 and N0->N2, where N1 is adjacent to N2. Set -C N3 to the node opposite N1->N2, and save N1 and N2 to -C test for cycling. +C N3 to the node opposite N1->N2. C 7 N3 = N0 - N1S = N1 - N2S = N2 C C Top of edge hopping loop. Test for termination. C @@ -3900,20 +4106,10 @@ C C C P LEFT N1->N2 and hence P is in (N1,N2,N3) unless an C error resulted from floating point inaccuracy and -C collinearity. Compute the unnormalized barycentric -C coordinates of P with respect to (N1,N2,N3). -C - B1 = (X(N3)-X(N2))*(YP-Y(N2)) - - . (XP-X(N2))*(Y(N3)-Y(N2)) - B2 = (X(N1)-X(N3))*(YP-Y(N3)) - - . (XP-X(N3))*(Y(N1)-Y(N3)) - IF (STORE(B1+1.) .GE. 1. .AND. - . STORE(B2+1.) .GE. 1.) GO TO 16 -C -C Restart with N0 randomly selected. +C collinearity. C - N0 = JRAND(N, IX,IY,IZ ) - GO TO 1 + IF ( LEFT(X(N2),Y(N2),X(N3),Y(N3),XP,YP) .AND. + . LEFT(X(N3),Y(N3),X(N1),Y(N1),XP,YP) ) GO TO 16 ENDIF C C Set N4 to the neighbor of N2 which follows N1 (node @@ -3934,21 +4130,11 @@ C IF ( LEFT(X(N0),Y(N0),X(N4),Y(N4),XP,YP) ) THEN N3 = N1 N1 = N4 - N2S = N2 - IF (N1 .NE. N1S .AND. N1 .NE. N0) GO TO 8 ELSE N3 = N2 N2 = N4 - N1S = N1 - IF (N2 .NE. N2S .AND. N2 .NE. N0) GO TO 8 ENDIF -C -C The starting node N0 or edge N1-N2 was encountered -C again, implying a cycle (infinite loop). Restart -C with N0 randomly selected. -C - N0 = JRAND(N, IX,IY,IZ ) - GO TO 1 + GO TO 8 C C Boundary traversal loops. NL->NF is a boundary edge and C P RIGHT NL->NF. Save NL and NF. @@ -4036,11 +4222,11 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 03/22/97 +C (817) 565-2767 +C 11/12/94 C C This subroutine converts a triangulation data structure -C from the linked list created by Subroutine TRMESH or +C from the linked list created by subroutine TRMESH or C TRMSHR to a triangle list. C C On input: @@ -4049,13 +4235,13 @@ C NCC = Number of constraints. NCC .GE. 0. C C LCC = List of constraint curve starting indexes (or C dummy array of length 1 if NCC = 0). Refer to -C Subroutine ADDCST. +C subroutine ADDCST. C C N = Number of nodes in the triangulation. N .GE. 3. C C LIST,LPTR,LEND = Linked list data structure defin- C ing the triangulation. Refer to -C Subroutine TRMESH. +C subroutine TRMESH. C C NROW = Number of rows (entries per triangle) re- C served for the triangle list LTRI. The value @@ -4335,10 +4521,9 @@ C END SUBROUTINE TRLPRT (NCC,LCT,N,X,Y,NROW,NT,LTRI,LOUT, . PRNTX) - INTEGER NCC, LCT(*), N, NROW, NT, LTRI(NROW,NT), - . LOUT + INTEGER NCC, LCT(*), N, NROW, NT, LTRI(NROW,NT), LOUT LOGICAL PRNTX - DOUBLE PRECISION X(N), Y(N) + DOUBLE PRECISION X(N), Y(N) C C*********************************************************** C @@ -4346,12 +4531,12 @@ C From TRLPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 07/02/98 +C (817) 565-2767 +C 08/22/91 C C Given a triangulation of a set of points in the plane, C this subroutine prints the triangle list created by -C Subroutine TRLIST and, optionally, the nodal coordinates +C subroutine TRLIST and, optionally, the nodal coordinates C on logical unit LOUT. The numbers of boundary nodes, C triangles, and arcs, and the constraint region triangle C indexes, if any, are also printed. @@ -4423,7 +4608,7 @@ C C C Print a heading and test for invalid input. C -C WRITE (LUN,100) +c WRITE (LUN,100) NL = 1 IF (N .LT. 3 .OR. N .GT. NMAX .OR. . (NROW .NE. 6 .AND. NROW .NE. 9) .OR. @@ -4431,21 +4616,21 @@ C WRITE (LUN,100) C C Print an error message and bypass the loops. C -C WRITE (LUN,110) N, NROW, NT +c WRITE (LUN,110) N, NROW, NT GO TO 3 ENDIF IF (PRNTX) THEN C C Print X and Y. C -C WRITE (LUN,101) +c WRITE (LUN,101) NL = 6 DO 1 I = 1,N IF (NL .GE. NLMAX) THEN -C WRITE (LUN,106) +c WRITE (LUN,106) NL = 0 ENDIF -C WRITE (LUN,102) I, X(I), Y(I) +c WRITE (LUN,102) I, X(I), Y(I) NL = NL + 1 1 CONTINUE ENDIF @@ -4453,21 +4638,21 @@ C C Print the triangulation LTRI. C IF (NL .GT. NLMAX/2) THEN -C WRITE (LUN,106) +c WRITE (LUN,106) NL = 0 ENDIF IF (NROW .EQ. 6) THEN -C WRITE (LUN,103) +c WRITE (LUN,103) ELSE -C WRITE (LUN,104) +c WRITE (LUN,104) ENDIF NL = NL + 5 DO 2 K = 1,NT IF (NL .GE. NLMAX) THEN -C WRITE (LUN,106) +c WRITE (LUN,106) NL = 0 ENDIF -C WRITE (LUN,105) K, (LTRI(I,K), I = 1,NROW) +c WRITE (LUN,105) K, (LTRI(I,K), I = 1,NROW) NL = NL + 1 2 CONTINUE C @@ -4476,43 +4661,41 @@ C triangles). C NB = 2*N - NT - 2 NA = NT + N - 1 -C IF (NL .GT. NLMAX-6) WRITE (LUN,106) -C WRITE (LUN,107) NB, NA, NT +c IF (NL .GT. NLMAX-6) WRITE (LUN,106) +c WRITE (LUN,107) NB, NA, NT C C Print NCC and LCT. C 3 CONTINUE -C 3 WRITE (LUN,108) NCC -C IF (NCC .GT. 0) WRITE (LUN,109) (LCT(I), I = 1,NCC) +c WRITE (LUN,108) NCC +c IF (NCC .GT. 0) WRITE (LUN,109) (LCT(I), I = 1,NCC) RETURN C C Print formats: C - 100 FORMAT (///,24X,'TRIPACK (TRLIST) Output') - 101 FORMAT (//16X,'Node',7X,'X(Node)',10X,'Y(Node)'//) + 100 FORMAT ('1',24X,'TRIPACK (TRLIST) OUTPUT') + 101 FORMAT (//16X,'NODE',7X,'X(NODE)',10X,'Y(NODE)'//) 102 FORMAT (16X,I4,2E17.6) - 103 FORMAT (//1X,'Triangle',8X,'Vertices',12X,'Neighbors'/ + 103 FORMAT (//1X,'TRIANGLE',8X,'VERTICES',12X,'NEIGHBORS'/ . 4X,'KT',7X,'N1',5X,'N2',5X,'N3',4X,'KT1',4X, . 'KT2',4X,'KT3'/) - 104 FORMAT (//1X,'Triangle',8X,'Vertices',12X,'Neighbors', - . 14X,'Arcs'/ + 104 FORMAT (//1X,'TRIANGLE',8X,'VERTICES',12X,'NEIGHBORS', + . 14X,'ARCS'/ . 4X,'KT',7X,'N1',5X,'N2',5X,'N3',4X,'KT1',4X, . 'KT2',4X,'KT3',4X,'KA1',4X,'KA2',4X,'KA3'/) 105 FORMAT (2X,I4,2X,6(3X,I4),3(2X,I5)) - 106 FORMAT (///) - 107 FORMAT (/1X,'NB = ',I4,' Boundary Nodes',5X, - . 'NA = ',I5,' Arcs',5X,'NT = ',I5, - . ' Triangles') - 108 FORMAT (/1X,'NCC =',I3,' Constraint Curves') + 106 FORMAT ('1') + 107 FORMAT (/1X,'NB = ',I4,' BOUNDARY NODES',5X, + . 'NA = ',I5,' ARCS',5X,'NT = ',I5, + . ' TRIANGLES') + 108 FORMAT (/1X,'NCC =',I3,' CONSTRAINT CURVES') 109 FORMAT (1X,9X,14I5) - 110 FORMAT (//1X,10X,'*** Invalid Parameter: N =',I5, + 110 FORMAT (//1X,10X,'*** INVALID PARAMETER: N =',I5, . ', NROW =',I5,', NT =',I5,' ***') END - SUBROUTINE TRMESH (N,X,Y, LIST,LPTR,LEND,LNEW,NEAR, - . NEXT,DIST,IER) - INTEGER N, LIST(*), LPTR(*), LEND(N), LNEW, NEAR(N), - . NEXT(N), IER - DOUBLE PRECISION X(N), Y(N), DIST(N) + SUBROUTINE TRMESH (N,X,Y, LIST,LPTR,LEND,LNEW,IER) + INTEGER N, LIST(*), LPTR(*), LEND(N), LNEW, IER + DOUBLE PRECISION X(N), Y(N) C C*********************************************************** C @@ -4520,8 +4703,8 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/28/98 +C (817) 565-2767 +C 08/25/91 C C This subroutine creates a Delaunay triangulation of a C set of N arbitrarily distributed points in the plane re- @@ -4546,13 +4729,13 @@ C for solving closest point problems and for triangle-based C interpolation. C C The triangulation can be generalized to a constrained -C Delaunay triangulation by a call to Subroutine ADDCST. +C Delaunay triangulation by a call to subroutine ADDCST. C This allows for user-specified boundaries defining a non- C convex and/or multiply connected region. C -C The algorithm for constructing the triangulation has -C expected time complexity O(N*log(N)) for most nodal dis- -C tributions. Also, since the algorithm proceeds by adding +C The operation count for constructing the triangulation +C is close to O(N) if the nodes are presorted on X or Y com- +C ponents. Also, since the algorithm proceeds by adding C nodes incrementally, the triangulation may be updated with C the addition (or deletion) of a node very efficiently. C The adjacency information representing the triangulation @@ -4600,15 +4783,20 @@ C C INTSEC - Determines whether or not an arbitrary pair of C line segments share a common point. C -C JRAND - Generates a uniformly distributed pseudo-random -C integer. -C C LEFT - Locates a point relative to a line. C C NEARND - Returns the index of the nearest node to an C arbitrary point, along with its squared C distance. C +C PERMUT - Permutes a vector. +C +C QSORT - Defines a permutation by applying a Quick Sort +C to a vector. +C +C REORDR - Reorders the nodes, using an order N*log(N) +C sort, for increased efficiency in TRMESH. +C C STORE - Forces a value to be stored in main memory so C that the precision of floating point numbers C in memory locations rather than registers is @@ -4618,7 +4806,7 @@ C TRLIST - Converts the triangulation data structure to a C triangle list more suitable for use in a fin- C ite element code. C -C TRLPRT - Prints the triangle list created by Subroutine +C TRLPRT - Prints the triangle list created by subroutine C TRLIST. C C TRMESH - Creates a Delaunay triangulation of a set of @@ -4629,9 +4817,6 @@ C ently than TRMESH) of a set of nodes lying at C the vertices of a (possibly skewed) rectangu- C lar grid. C -C TRPLOT - Creates a level-2 Encapsulated Postscript (EPS) -C file containing a triangulation plot. -C C TRPRNT - Prints the triangulation data structure and, C optionally, the nodal coordinates. C @@ -4652,12 +4837,6 @@ C LIST,LPTR = Arrays of length at least 6N-12. C C LEND = Array of length at least N. C -C NEAR,NEXT,DIST = Work space arrays of length at -C least N. The space is used to -C efficiently determine the nearest -C triangulation node to each un- -C processed node for use by ADDNOD. -C C On output: C C LIST = Set of nodal indexes which, along with LPTR, @@ -4689,57 +4868,27 @@ C and LPTR (list length plus one). LIST, LPTR, C LEND, and LNEW are not altered if IER < 0, C and are incomplete if IER > 0. C -C NEAR,NEXT,DIST = Garbage. -C C IER = Error indicator: C IER = 0 if no errors were encountered. C IER = -1 if N < 3 on input. C IER = -2 if the first three nodes are C collinear. -C IER = -4 if an error flag was returned by a -C call to SWAP in ADDNOD. This is an -C internal error and should be reported -C to the programmer. C IER = L if nodes L and M coincide for some C M > L. The linked list represents C a triangulation of nodes 1 to M-1 C in this case. C C Modules required by TRMESH: ADDNOD, BDYADD, INSERT, -C INTADD, JRAND, LEFT, -C LSTPTR, STORE, SWAP, -C SWPTST, TRFIND -C -C Intrinsic function called by TRMESH: ABS +C INTADD, LEFT, LSTPTR, +C STORE, SWAP, SWPTST, TRFIND C C*********************************************************** C LOGICAL LEFT - DOUBLE PRECISION STORE - INTEGER I, I0, J, K, KM1, LCC(1), LP, LPL, NCC, NEXTI, - . NN - DOUBLE PRECISION D, D1, D2, D3, EPS, SWTOL + DOUBLE PRECISION STORE + INTEGER K, KM1, LCC(1), NCC, NN + DOUBLE PRECISION EPS, SWTOL COMMON/SWPCOM/SWTOL -C -C Local parameters: -C -C D = Squared distance from node K to node I -C D1,D2,D3 = Squared distances from node K to nodes 1, 2, -C and 3, respectively -C EPS = Half the machine precision -C I,J = Nodal indexes -C I0 = Index of the node preceding I in a sequence of -C unprocessed nodes: I = NEXT(I0) -C K = Index of node to be added and DO-loop index: -C K > 3 -C KM1 = K-1 -C LCC(1) = Dummy array -C LP = LIST index (pointer) of a neighbor of K -C LPL = Pointer to the last neighbor of K -C NCC = Number of constraint curves -C NEXTI = NEXT(I) -C NN = Local copy of N -C SWTOL = Tolerance for function SWPTST C NN = N IF (NN .LT. 3) THEN @@ -4760,7 +4909,7 @@ C Store the first triangle in the linked list. C IF ( .NOT. LEFT(X(1),Y(1),X(2),Y(2),X(3),Y(3)) ) THEN C -C The initial triangle is (3,2,1) = (2,1,3) = (1,3,2). +C The initial triangle is (1,3,2). C LIST(1) = 3 LPTR(1) = 2 @@ -4811,152 +4960,36 @@ C RETURN ENDIF C -C Initialize LNEW and test for N = 3. +C Initialize LNEW and add the remaining nodes. Parameters +C for ADDNOD are as follows: +C +C K = Index of the node to be added. +C KM1 = Index of the starting node for the search in +C TRFIND and number of nodes in the triangulation +C on input. +C NCC = Number of constraint curves. +C LCC = Dummy array (since NCC = 0). C LNEW = 7 IF (NN .EQ. 3) THEN IER = 0 RETURN ENDIF -C -C A nearest-node data structure (NEAR, NEXT, and DIST) is -C used to obtain an expected-time (N*log(N)) incremental -C algorithm by enabling constant search time for locating -C each new node in the triangulation. -C -C For each unprocessed node K, NEAR(K) is the index of the -C triangulation node closest to K (used as the starting -C point for the search in Subroutine TRFIND) and DIST(K) -C is an increasing function of the distance between nodes -C K and NEAR(K). -C -C Since it is necessary to efficiently find the subset of -C unprocessed nodes associated with each triangulation -C node J (those that have J as their NEAR entries), the -C subsets are stored in NEAR and NEXT as follows: for -C each node J in the triangulation, I = NEAR(J) is the -C first unprocessed node in J's set (with I = 0 if the -C set is empty), L = NEXT(I) (if I > 0) is the second, -C NEXT(L) (if L > 0) is the third, etc. The nodes in each -C set are initially ordered by increasing indexes (which -C maximizes efficiency) but that ordering is not main- -C tained as the data structure is updated. -C -C Initialize the data structure for the single triangle. -C - NEAR(1) = 0 - NEAR(2) = 0 - NEAR(3) = 0 - DO 2 K = NN,4,-1 - D1 = (X(K)-X(1))**2 + (Y(K)-Y(1))**2 - D2 = (X(K)-X(2))**2 + (Y(K)-Y(2))**2 - D3 = (X(K)-X(3))**2 + (Y(K)-Y(3))**2 - IF (D1 .LE. D2 .AND. D1 .LE. D3) THEN - NEAR(K) = 1 - DIST(K) = D1 - NEXT(K) = NEAR(1) - NEAR(1) = K - ELSEIF (D2 .LE. D1 .AND. D2 .LE. D3) THEN - NEAR(K) = 2 - DIST(K) = D2 - NEXT(K) = NEAR(2) - NEAR(2) = K - ELSE - NEAR(K) = 3 - DIST(K) = D3 - NEXT(K) = NEAR(3) - NEAR(3) = K - ENDIF - 2 CONTINUE -C -C Add the remaining nodes. Parameters for ADDNOD are as -C follows: -C -C K = Index of the node to be added. -C NEAR(K) = Index of the starting node for the search in -C TRFIND. -C NCC = Number of constraint curves. -C LCC = Dummy array (since NCC = 0). -C KM1 = Number of nodes in the triangulation. -C NCC = 0 - DO 7 K = 4,NN - KM1 = K-1 - CALL ADDNOD (K,X(K),Y(K),NEAR(K),NCC, LCC,KM1,X,Y, + DO 2 K = 4,NN + KM1 = K - 1 + CALL ADDNOD (K,X(K),Y(K),KM1,NCC, LCC,KM1,X,Y, . LIST,LPTR,LEND,LNEW, IER) IF (IER .NE. 0) RETURN -C -C Remove K from the set of unprocessed nodes associated -C with NEAR(K). -C - I = NEAR(K) - IF (NEAR(I) .EQ. K) THEN - NEAR(I) = NEXT(K) - ELSE - I = NEAR(I) - 3 I0 = I - I = NEXT(I0) - IF (I .NE. K) GO TO 3 - NEXT(I0) = NEXT(K) - ENDIF - NEAR(K) = 0 -C -C Loop on neighbors J of node K. -C - LPL = LEND(K) - LP = LPL - 4 LP = LPTR(LP) - J = ABS(LIST(LP)) -C -C Loop on elements I in the sequence of unprocessed nodes -C associated with J: K is a candidate for replacing J -C as the nearest triangulation node to I. The next value -C of I in the sequence, NEXT(I), must be saved before I -C is moved because it is altered by adding I to K's set. -C - I = NEAR(J) - 5 IF (I .EQ. 0) GO TO 6 - NEXTI = NEXT(I) -C -C Test for the distance from I to K less than the distance -C from I to J. -C - D = (X(K)-X(I))**2 + (Y(K)-Y(I))**2 - IF (D .LT. DIST(I)) THEN -C -C Replace J by K as the nearest triangulation node to I: -C update NEAR(I) and DIST(I), and remove I from J's set -C of unprocessed nodes and add it to K's set. -C - NEAR(I) = K - DIST(I) = D - IF (I .EQ. NEAR(J)) THEN - NEAR(J) = NEXTI - ELSE - NEXT(I0) = NEXTI - ENDIF - NEXT(I) = NEAR(K) - NEAR(K) = I - ELSE - I0 = I - ENDIF -C -C Bottom of loop on I. -C - I = NEXTI - GO TO 5 -C -C Bottom of loop on neighbors J. -C - 6 IF (LP .NE. LPL) GO TO 4 - 7 CONTINUE + 2 CONTINUE + IER = 0 RETURN END SUBROUTINE TRMSHR (N,NX,X,Y, NIT, LIST,LPTR,LEND,LNEW, . IER) INTEGER N, NX, NIT, LIST(*), LPTR(*), LEND(N), LNEW, . IER - DOUBLE PRECISION X(N), Y(N) + DOUBLE PRECISION X(N), Y(N) C C*********************************************************** C @@ -4964,8 +4997,8 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 06/27/98 +C (817) 565-2767 +C 08/31/91 C C This subroutine creates a Delaunay triangulation of a C set of N nodes in the plane, where the nodes are the vert- @@ -4981,8 +5014,8 @@ C mation from a rectangle to a grid cell which is bilinear C in both components has an invertible Jacobian. C C If the nodes are not distributed and ordered as defined -C above, Subroutine TRMESH must be called in place of this -C routine. Refer to Subroutine ADDCST for the treatment of +C above, subroutine TRMESH must be called in place of this +C routine. Refer to subroutine ADDCST for the treatment of C constraints. C C The first phase of the algorithm consists of construc- @@ -5036,7 +5069,7 @@ C C NIT = Number of iterations employed. C C LIST,LPTR,LEND,LNEW = Data structure defining the -C triangulation. Refer to Sub- +C triangulation. Refer to sub- C routine TRMESH. C C IER = Error indicator: @@ -5065,12 +5098,12 @@ C*********************************************************** C INTEGER LSTPTR, NBCNT LOGICAL LEFT, SWPTST - DOUBLE PRECISION STORE + DOUBLE PRECISION STORE INTEGER I, ITER, J, K, KP1, LP, LPF, LPK, LPL, LPP, . M1, M2, M3, M4, MAXIT, N0, N1, N2, N3, N4, NI, . NJ, NM1, NN, NNB LOGICAL TST - DOUBLE PRECISION EPS, SWTOL + DOUBLE PRECISION EPS, SWTOL COMMON/SWPCOM/SWTOL C C Store local variables and test for errors in input @@ -5336,10 +5369,8 @@ C Swap diagonal N1-N2 for N3-N4, set TST to TRUE, and set C N2 to N4 (the neighbor preceding N3). C CALL SWAP (N3,N4,N1,N2, LIST,LPTR,LEND, LPP) - IF (LPP .NE. 0) THEN - TST = .TRUE. - N2 = N4 - ENDIF + TST = .TRUE. + N2 = N4 ENDIF ENDIF C @@ -5364,469 +5395,6 @@ C C Invalid grid cell encountered. C 12 IER = K - RETURN - END - SUBROUTINE TRPLOT (LUN,PLTSIZ,WX1,WX2,WY1,WY2,NCC,LCC, - . N,X,Y,LIST,LPTR,LEND,TITLE, - . NUMBR, IER) - CHARACTER*(*) TITLE - INTEGER LUN, NCC, LCC(*), N, LIST(*), LPTR(*), - . LEND(N), IER - LOGICAL NUMBR - DOUBLE PRECISION PLTSIZ, WX1, WX2, WY1, WY2, X(N), - . Y(N) -C -C*********************************************************** -C -C From TRIPACK -C Robert J. Renka -C Dept. of Computer Science -C Univ. of North Texas -C renka@cs.unt.edu -C 07/15/98 -C -C This subroutine creates a level-2 Encapsulated Post- -C script (EPS) file containing a triangulation plot. -C -C -C On input: -C -C LUN = Logical unit number in the range 0 to 99. -C The unit should be opened with an appropriate -C file name before the call to this routine. -C -C PLTSIZ = Plot size in inches. The window is mapped, -C with aspect ratio preserved, to a rectangu- -C lar viewport with maximum side-length equal -C to .88*PLTSIZ (leaving room for labels out- -C side the viewport). The viewport is -C centered on the 8.5 by 11 inch page, and -C its boundary is drawn. 1.0 .LE. PLTSIZ -C .LE. 8.5. -C -C WX1,WX2,WY1,WY2 = Parameters defining a rectangular -C window against which the triangu- -C lation is clipped. (Only the -C portion of the triangulation that -C lies in the window is drawn.) -C (WX1,WY1) and (WX2,WY2) are the -C lower left and upper right cor- -C ners, respectively. WX1 < WX2 and -C WY1 < WY2. -C -C NCC = Number of constraint curves. Refer to Subrou- -C tine ADDCST. NCC .GE. 0. -C -C LCC = Array of length NCC (or dummy parameter if -C NCC = 0) containing the index of the first -C node of constraint I in LCC(I). For I = 1 to -C NCC, LCC(I+1)-LCC(I) .GE. 3, where LCC(NCC+1) -C = N+1. -C -C N = Number of nodes in the triangulation. N .GE. 3. -C -C X,Y = Arrays of length N containing the coordinates -C of the nodes with non-constraint nodes in the -C first LCC(1)-1 locations. -C -C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine -C TRMESH. -C -C TITLE = Type CHARACTER variable or constant contain- -C ing a string to be centered above the plot. -C The string must be enclosed in parentheses; -C i.e., the first and last characters must be -C '(' and ')', respectively, but these are not -C displayed. TITLE may have at most 80 char- -C acters including the parentheses. -C -C NUMBR = Option indicator: If NUMBR = TRUE, the -C nodal indexes are plotted next to the nodes. -C -C Input parameters are not altered by this routine. -C -C On output: -C -C IER = Error indicator: -C IER = 0 if no errors were encountered. -C IER = 1 if LUN, PLTSIZ, NCC, or N is outside -C its valid range. LCC is not tested -C for validity. -C IER = 2 if WX1 >= WX2 or WY1 >= WY2. -C IER = 3 if an error was encountered in writing -C to unit LUN. -C -C Various plotting options can be controlled by altering -C the data statement below. -C -C Modules required by TRPLOT: None -C -C Intrinsic functions called by TRPLOT: ABS, CHAR, NINT, -C DBLE -C -C*********************************************************** -C - INTEGER I, IFRST, IH, ILAST, IPX1, IPX2, IPY1, IPY2, - . IW, LP, LPL, N0, N0BAK, N0FOR, N1, NLS - LOGICAL ANNOT, CNSTR, PASS1 - DOUBLE PRECISION DASHL, DX, DY, FSIZN, FSIZT, R, SFX, - . SFY, T, TX, TY, X0, Y0 -C - DATA ANNOT/.TRUE./, DASHL/4.0/, FSIZN/10.0/, - . FSIZT/16.0/ -C -C Local parameters: -C -C ANNOT = Logical variable with value TRUE iff the plot -C is to be annotated with the values of WX1, -C WX2, WY1, and WY2 -C CNSTR Logical variable used to flag constraint arcs: -C TRUE iff N0-N1 lies in a constraint region -C DASHL = Length (in points, at 72 points per inch) of -C dashes and spaces in a dashed line pattern -C used for drawing constraint arcs -C DX = Window width WX2-WX1 -C DY = Window height WY2-WY1 -C FSIZN = Font size in points for labeling nodes with -C their indexes if NUMBR = TRUE -C FSIZT = Font size in points for the title (and -C annotation if ANNOT = TRUE) -C I = Constraint index (1 to NCC) -C IFRST = Index of the first node in constraint I -C IH = Height of the viewport in points -C ILAST = Index of the last node in constraint I -C IPX1,IPY1 = X and y coordinates (in points) of the lower -C left corner of the bounding box or viewport -C IPX2,IPY2 = X and y coordinates (in points) of the upper -C right corner of the bounding box or viewport -C IW = Width of the viewport in points -C LP = LIST index (pointer) -C LPL = Pointer to the last neighbor of N0 -C N0 = Nodal index and DO-loop index -C N0BAK = Predecessor of N0 in a constraint curve -C (sequence of adjacent constraint nodes) -C N0FOR = Successor to N0 in a constraint curve -C N1 = Index of a neighbor of N0 -C NLS = Index of the last non-constraint node -C PASS1 = Logical variable used to flag the first pass -C through the constraint nodes -C R = Aspect ratio DX/DY -C SFX,SFY = Scale factors for mapping world coordinates -C (window coordinates in [WX1,WX2] X [WY1,WY2]) -C to viewport coordinates in [IPX1,IPX2] X -C [IPY1,IPY2] -C T = Temporary variable -C TX,TY = Translation vector for mapping world coordi- -C nates to viewport coordinates -C X0,Y0 = X(N0),Y(N0) or label location -C -C -C Test for error 1, and set NLS to the last non-constraint -C node. -C - IF (LUN .LT. 0 .OR. LUN .GT. 99 .OR. - . PLTSIZ .LT. 1.0 .OR. PLTSIZ .GT. 8.5 .OR. - . NCC .LT. 0 .OR. N .LT. 3) GO TO 11 - NLS = N - IF (NCC .GT. 0) NLS = LCC(1)-1 -C -C Compute the aspect ratio of the window. -C - DX = WX2 - WX1 - DY = WY2 - WY1 - IF (DX .LE. 0.0 .OR. DY .LE. 0.0) GO TO 12 - R = DX/DY -C -C Compute the lower left (IPX1,IPY1) and upper right -C (IPX2,IPY2) corner coordinates of the bounding box. -C The coordinates, specified in default user space units -C (points, at 72 points/inch with origin at the lower -C left corner of the page), are chosen to preserve the -C aspect ratio R, and to center the plot on the 8.5 by 11 -C inch page. The center of the page is (306,396), and -C T = PLTSIZ/2 in points. -C - T = 36.0*PLTSIZ - IF (R .GE. 1.0) THEN - IPX1 = 306 - NINT(T) - IPX2 = 306 + NINT(T) - IPY1 = 396 - NINT(T/R) - IPY2 = 396 + NINT(T/R) - ELSE - IPX1 = 306 - NINT(T*R) - IPX2 = 306 + NINT(T*R) - IPY1 = 396 - NINT(T) - IPY2 = 396 + NINT(T) - ENDIF -C -C Output header comments. -C -C WRITE (LUN,100,ERR=13) IPX1, IPY1, IPX2, IPY2 - 100 FORMAT ('%!PS-Adobe-3.0 EPSF-3.0'/ - . '%%BoundingBox:',4I4/ - . '%%Title: Triangulation'/ - . '%%Creator: TRIPACK'/ - . '%%EndComments') -C -C Set (IPX1,IPY1) and (IPX2,IPY2) to the corner coordinates -C of a viewport obtained by shrinking the bounding box by -C 12% in each dimension. -C - IW = NINT(0.88*DBLE(IPX2-IPX1)) - IH = NINT(0.88*DBLE(IPY2-IPY1)) - IPX1 = 306 - IW/2 - IPX2 = 306 + IW/2 - IPY1 = 396 - IH/2 - IPY2 = 396 + IH/2 -C -C Set the line thickness to 2 points, and draw the -C viewport boundary. -C - T = 2.0 -C WRITE (LUN,110,ERR=13) T -C WRITE (LUN,120,ERR=13) IPX1, IPY1 -C WRITE (LUN,130,ERR=13) IPX1, IPY2 -C WRITE (LUN,130,ERR=13) IPX2, IPY2 -C WRITE (LUN,130,ERR=13) IPX2, IPY1 -C WRITE (LUN,140,ERR=13) -C WRITE (LUN,150,ERR=13) - 110 FORMAT (F12.6,' setlinewidth') - 120 FORMAT (2I4,' moveto') - 130 FORMAT (2I4,' lineto') - 140 FORMAT ('closepath') - 150 FORMAT ('stroke') -C -C Set up a mapping from the window to the viewport. -C - SFX = DBLE(IW)/DX - SFY = DBLE(IH)/DY - TX = IPX1 - SFX*WX1 - TY = IPY1 - SFY*WY1 -C WRITE (LUN,160,ERR=13) TX, TY, SFX, SFY - 160 FORMAT (2F12.6,' translate'/ - . 2F12.6,' scale') -C -C The line thickness (believe it or fucking not) must be -C changed to reflect the new scaling which is applied to -C all subsequent output. Set it to 1.0 point. -C - T = 2.0/(SFX+SFY) -C WRITE (LUN,110,ERR=13) T -C -C Save the current graphics state, and set the clip path to -C the boundary of the window. -C -C WRITE (LUN,170,ERR=13) -C WRITE (LUN,180,ERR=13) WX1, WY1 -C WRITE (LUN,190,ERR=13) WX2, WY1 -C WRITE (LUN,190,ERR=13) WX2, WY2 -C WRITE (LUN,190,ERR=13) WX1, WY2 -C WRITE (LUN,200,ERR=13) - 170 FORMAT ('gsave') - 180 FORMAT (2F12.6,' moveto') - 190 FORMAT (2F12.6,' lineto') - 200 FORMAT ('closepath clip newpath') -C -C Draw the edges N0->N1, where N1 > N0, beginning with a -C loop on non-constraint nodes N0. LPL points to the -C last neighbor of N0. -C - DO 3 N0 = 1,NLS - X0 = X(N0) - Y0 = Y(N0) - LPL = LEND(N0) - LP = LPL -C -C Loop on neighbors N1 of N0. -C - 2 LP = LPTR(LP) - N1 = ABS(LIST(LP)) - IF (N1 .GT. N0) THEN -C -C Add the edge to the path. -C -C WRITE (LUN,210,ERR=13) X0, Y0, X(N1), Y(N1) - 210 FORMAT (2F12.6,' moveto',2F12.6,' lineto') - ENDIF - IF (LP .NE. LPL) GO TO 2 - 3 CONTINUE -C -C Loop through the constraint nodes twice. The non- -C constraint arcs incident on constraint nodes are -C drawn (with solid lines) on the first pass, and the -C constraint arcs (both boundary and interior, if any) -C are drawn (with dashed lines) on the second pass. -C - PASS1 = .TRUE. -C -C Loop on constraint nodes N0 with (N0BAK,N0,N0FOR) a sub- -C sequence of constraint I. The outer loop is on -C constraints I with first and last nodes IFRST and ILAST. -C - 4 IFRST = N+1 - DO 8 I = NCC,1,-1 - ILAST = IFRST - 1 - IFRST = LCC(I) - N0BAK = ILAST - DO 7 N0 = IFRST,ILAST - N0FOR = N0 + 1 - IF (N0 .EQ. ILAST) N0FOR = IFRST - LPL = LEND(N0) - X0 = X(N0) - Y0 = Y(N0) - LP = LPL -C -C Loop on neighbors N1 of N0. CNSTR = TRUE iff N0-N1 is a -C constraint arc. -C -C Initialize CNSTR to TRUE iff the first neighbor of N0 -C strictly follows N0FOR and precedes or coincides with -C N0BAK (in counterclockwise order). -C - 5 LP = LPTR(LP) - N1 = ABS(LIST(LP)) - IF (N1 .NE. N0FOR .AND. N1 .NE. N0BAK) GO TO 5 - CNSTR = N1 .EQ. N0BAK - LP = LPL -C -C Loop on neighbors N1 of N0. Update CNSTR and test for -C N1 > N0. -C - 6 LP = LPTR(LP) - N1 = ABS(LIST(LP)) - IF (N1 .EQ. N0FOR) CNSTR = .TRUE. - IF (N1 .GT. N0) THEN -C -C Draw the edge iff (PASS1=TRUE and CNSTR=FALSE) or -C (PASS1=FALSE and CNSTR=TRUE); i.e., CNSTR and PASS1 -C have opposite values. -C -C IF (CNSTR .NEQV. PASS1) -C . WRITE (LUN,210,ERR=13) X0, Y0, X(N1), Y(N1) - ENDIF - IF (N1 .EQ. N0BAK) CNSTR = .FALSE. -C -C Bottom of loops. -C - IF (LP .NE. LPL) GO TO 6 - N0BAK = N0 - 7 CONTINUE - 8 CONTINUE - IF (PASS1) THEN -C -C End of first pass: paint the path and change to dashed -C lines for subsequent drawing. Since the scale factors -C are applied to everything, the dash length must be -C specified in world coordinates. -C - PASS1 = .FALSE. -C WRITE (LUN,150,ERR=13) - T = DASHL*2.0/(SFX+SFY) -C WRITE (LUN,220,ERR=13) T - 220 FORMAT ('[',F12.6,'] 0 setdash') - GO TO 4 - ENDIF -C -C Paint the path and restore the saved graphics state (with -C no clip path). -C -C WRITE (LUN,150,ERR=13) -C WRITE (LUN,230,ERR=13) - 230 FORMAT ('grestore') - IF (NUMBR) THEN -C -C Nodes in the window are to be labeled with their indexes. -C Convert FSIZN from points to world coordinates, and -C output the commands to select a font and scale it. -C - T = FSIZN*2.0/(SFX+SFY) -C WRITE (LUN,240,ERR=13) T - 240 FORMAT ('/Helvetica findfont'/ - . F12.6,' scalefont setfont') -C -C Loop on nodes N0 with coordinates (X0,Y0). -C - DO 9 N0 = 1,N - X0 = X(N0) - Y0 = Y(N0) - IF (X0 .LT. WX1 .OR. X0 .GT. WX2 .OR. - . Y0 .LT. WY1 .OR. Y0 .GT. WY2) GO TO 9 -C -C Move to (X0,Y0), and draw the label N0. The first char- -C acter will have its lower left corner about one -C character width to the right of the nodal position. -C -C WRITE (LUN,180,ERR=13) X0, Y0 -C WRITE (LUN,250,ERR=13) N0 - 250 FORMAT ('(',I3,') show') - 9 CONTINUE - ENDIF -C -C Convert FSIZT from points to world coordinates, and output -C the commands to select a font and scale it. -C - T = FSIZT*2.0/(SFX+SFY) -C WRITE (LUN,240,ERR=13) T -C -C Display TITLE centered above the plot: -C - Y0 = WY2 + 3.0*T -C WRITE (LUN,260,ERR=13) TITLE, (WX1+WX2)/2.0, Y0 - 260 FORMAT (A80/' stringwidth pop 2 div neg ',F12.6, - . ' add ',F12.6,' moveto') -C WRITE (LUN,270,ERR=13) TITLE - 270 FORMAT (A80/' show') - IF (ANNOT) THEN -C -C Display the window extrema below the plot. -C - X0 = WX1 - Y0 = WY1 - 100.0/(SFX+SFY) -C WRITE (LUN,180,ERR=13) X0, Y0 -C WRITE (LUN,280,ERR=13) WX1, WX2 - Y0 = Y0 - 2.0*T -C WRITE (LUN,290,ERR=13) X0, Y0, WY1, WY2 - 280 FORMAT ('(Window: WX1 = ',E9.3,', WX2 = ',E9.3, - . ') show') - 290 FORMAT ('(Window: ) stringwidth pop ',F12.6,' add', - . F12.6,' moveto'/ - . '( WY1 = ',E9.3,', WY2 = ',E9.3,') show') - ENDIF -C -C Paint the path and output the showpage command and -C end-of-file indicator. -C -C WRITE (LUN,300,ERR=13) - 300 FORMAT ('stroke'/ - . 'showpage'/ - . '%%EOF') -C -C HP's interpreters require a one-byte End-of-PostScript-Job -C indicator (to eliminate a timeout error message): -C ASCII 4. -C -C WRITE (LUN,310,ERR=13) CHAR(4) - 310 FORMAT (A1) -C -C No error encountered. -C - IER = 0 - RETURN -C -C Invalid input parameter. -C - 11 IER = 1 - RETURN -C -C DX or DY is not positive. -C - 12 IER = 2 - RETURN -C -C Error writing to unit LUN. -C - 13 IER = 3 RETURN END SUBROUTINE TRPRNT (NCC,LCC,N,X,Y,LIST,LPTR,LEND,LOUT, @@ -5834,7 +5402,7 @@ C INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N), . LOUT LOGICAL PRNTX - DOUBLE PRECISION X(N), Y(N) + DOUBLE PRECISION X(N), Y(N) C C*********************************************************** C @@ -5842,8 +5410,8 @@ C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas -C renka@cs.unt.edu -C 07/30/98 +C (817) 565-2767 +C 08/22/91 C C Given a triangulation of a set of points in the plane, C this subroutine prints the adjacency lists and, option- @@ -5869,7 +5437,7 @@ C of the nodes in the triangulation -- not used C unless PRNTX = TRUE. C C LIST,LPTR,LEND = Data structure defining the trian- -C gulation. Refer to Subroutine +C gulation. Refer to subroutine C TRMESH. C C LOUT = Logical unit number for output. 0 .LE. LOUT @@ -5886,7 +5454,7 @@ C Modules required by TRPRNT: None C C*********************************************************** C - INTEGER I, INC, K, LP, LPL, LUN, NA, NABOR(100), NB, + INTEGER I, INC, K, LP, LPL, LUN, NA, NABOR(30), NB, . ND, NL, NLMAX, NMAX, NODE, NN, NT DATA NMAX/9999/, NLMAX/60/ C @@ -5896,12 +5464,12 @@ C C C Print a heading and test the range of N. C -C WRITE (LUN,100) NN +c WRITE (LUN,100) NN IF (NN .LT. 3 .OR. NN .GT. NMAX) THEN C C N is outside its valid range. C -C WRITE (LUN,110) +c WRITE (LUN,110) GO TO 5 ENDIF C @@ -5915,7 +5483,7 @@ C C Print LIST only. K is the number of neighbors of NODE C which are stored in NABOR. C -C WRITE (LUN,101) +c WRITE (LUN,101) DO 2 NODE = 1,NN LPL = LEND(NODE) LP = LPL @@ -5943,17 +5511,17 @@ C INC = (K-1)/14 + 2 NL = NL + INC IF (NL .GT. NLMAX) THEN -C WRITE (LUN,106) +c WRITE (LUN,106) NL = INC ENDIF -C WRITE (LUN,103) NODE, (NABOR(I), I = 1,K) -C IF (K .NE. 14) WRITE (LUN,105) +c WRITE (LUN,103) NODE, (NABOR(I), I = 1,K) +c IF (K .NE. 14) WRITE (LUN,105) 2 CONTINUE ELSE C C Print X, Y, and LIST. C -C WRITE (LUN,102) +c WRITE (LUN,102) DO 4 NODE = 1,NN LPL = LEND(NODE) LP = LPL @@ -5978,12 +5546,12 @@ C INC = (K-1)/8 + 2 NL = NL + INC IF (NL .GT. NLMAX) THEN -C WRITE (LUN,106) +c WRITE (LUN,106) NL = INC ENDIF -C WRITE (LUN,104) NODE, X(NODE), Y(NODE), - . (NABOR(I), I = 1,K) -C IF (K .NE. 8) WRITE (LUN,105) +c WRITE (LUN,104) NODE, X(NODE), Y(NODE), +c . (NABOR(I), I = 1,K) +c IF (K .NE. 8) WRITE (LUN,105) 4 CONTINUE ENDIF C @@ -5992,31 +5560,31 @@ C triangles). C NT = 2*NN - NB - 2 NA = NT + NN - 1 -C IF (NL .GT. NLMAX-6) WRITE (LUN,106) -C WRITE (LUN,107) NB, NA, NT +c IF (NL .GT. NLMAX-6) WRITE (LUN,106) +c WRITE (LUN,107) NB, NA, NT C C Print NCC and LCC. C 5 CONTINUE -C WRITE (LUN,108) NCC -C IF (NCC .GT. 0) WRITE (LUN,109) (LCC(I), I = 1,NCC) +c WRITE (LUN,108) NCC +c IF (NCC .GT. 0) WRITE (LUN,109) (LCC(I), I = 1,NCC) RETURN C C Print formats: C - 100 FORMAT (///,26X,'Adjacency Sets, N = ',I5//) - 101 FORMAT (1X,'Node',32X,'Neighbors of Node'//) - 102 FORMAT (1X,'Node',5X,'X(Node)',8X,'Y(Node)', - . 20X,'Neighbors of Node'//) + 100 FORMAT ('1',26X,'ADJACENCY SETS, N = ',I5//) + 101 FORMAT (1X,'NODE',32X,'NEIGHBORS OF NODE'//) + 102 FORMAT (1X,'NODE',5X,'X(NODE)',8X,'Y(NODE)', + . 20X,'NEIGHBORS OF NODE'//) 103 FORMAT (1X,I4,5X,14I5/(1X,9X,14I5)) 104 FORMAT (1X,I4,2E15.6,5X,8I5/(1X,39X,8I5)) 105 FORMAT (1X) - 106 FORMAT (///) - 107 FORMAT (/1X,'NB = ',I4,' Boundary Nodes',5X, - . 'NA = ',I5,' Arcs',5X,'NT = ',I5, - . ' Triangles') - 108 FORMAT (/1X,'NCC =',I3,' Constraint Curves') + 106 FORMAT ('1') + 107 FORMAT (/1X,'NB = ',I4,' BOUNDARY NODES',5X, + . 'NA = ',I5,' ARCS',5X,'NT = ',I5, + . ' TRIANGLES') + 108 FORMAT (/1X,'NCC =',I3,' CONSTRAINT CURVES') 109 FORMAT (1X,9X,14I5) - 110 FORMAT (1X,10X,'*** N is outside its valid', - . ' range ***') + 110 FORMAT (1X,10X,'*** N IS OUTSIDE ITS VALID', + . ' RANGE ***') END