Codebase list r-cran-randomfieldsutils / 83a33fe
New upstream version 0.5.3 Andreas Tille 4 years ago
83 changed file(s) with 5831 addition(s) and 2548 deletion(s). Raw diff Collapse all Expand all
00 Package: RandomFieldsUtils
1 Version: 0.3.25
1 Version: 0.5.3
22 Title: Utilities for the Simulation and Analysis of Random Fields
3 Author: Martin Schlather [aut, cre], Reinhard Furrer [ctb], Martin Kroll [ctb]
3 Author: Martin Schlather [aut, cre], Reinhard Furrer [ctb], Martin Kroll [ctb], Brian D. Ripley [ctb]
44 Maintainer: Martin Schlather <schlather@math.uni-mannheim.de>
5 Depends: R (>= 3.3)
6 Imports: utils
5 Depends: R (>= 3.0)
6 Imports: utils, methods
77 Description: Various utilities are provided that might be used in spatial statistics and elsewhere. It delivers a method for solving linear equations that checks the sparsity of the matrix before any algorithm is used. Furthermore, it includes the Struve functions.
88 License: GPL (>= 3)
9 URL: http://ms.math.uni-mannheim.de/de/publications/software
10 Packaged: 2017-04-14 06:09:19 UTC; schlather
9 URL:
10 http://ms.math.uni-mannheim.de/de/publications/software/randomfieldsutils
11 Packaged: 2019-03-02 22:43:06 UTC; schlather
1112 NeedsCompilation: yes
1213 Repository: CRAN
13 Date/Publication: 2017-04-14 15:07:28 UTC
14 Date/Publication: 2019-03-04 12:00:06 UTC
+78
-53
MD5 less more
0 23e06b94ac0894fb894b8330a144436a *DESCRIPTION
1 08e4bcd6eff029d24db78dcf53f79894 *NAMESPACE
2 acabf021c425958b8b2b7bebf4034be2 *R/RFoptions.R
0 fcfcdb07b56135a76aef2be41000de4d *DESCRIPTION
1 3a4095893bd12b2a643af33d9b007c0b *NAMESPACE
2 aa9ec314381f792108e1bd394e496e08 *R/RFoptions.R
3 77d7b538a03a79a88609bd338cfb5a75 *R/aaa_auto.R
4 be3837dca4524c805d265618dbf8e531 *R/internal_use.R
35 3324a6ddfcf33c60b75eb11793125fbd *R/maths.R
4 feaa9602b2d967cc42f36b0f911787cf *R/utils.R
5 06a4e00616dc945cdad05519f53e8582 *R/zzz.R
6 a021bfabf5361d383820398d4473bfe7 *inst/CITATION
7 87386da75db85d7fc88ab1c46261c94f *inst/include/Basic_utils.h
8 39598aef7112741a19221ed37181d83d *inst/include/General_utils.h
9 83ff926b36e383a5b4fd19bafc65d424 *inst/include/Options_utils.h
10 5c2fa3fdbde3b9e587dd4f5a7216a6cc *inst/include/Solve.h
11 f3970e74b496a033cea94b92c9603de7 *inst/include/errors_messages.h
12 3b920f7dab7aa23f847475163ec7d649 *inst/include/init_RandomFieldsUtils.h
13 994e648ba036ca9d2a62784c35fec0c4 *inst/include/kleinkram.h
14 a74b10a955ed930d76095b58caf5e3ce *inst/include/win_linux_aux.h
15 29fbe043cf6de23fc0d1e599a85a7054 *man/Print.Rd
16 416de51881b2e7a02ece5da10846ac61 *man/RFoptions.Rd
17 81981c0e2e019bf5ccbe8246806893c9 *man/Struve.Rd
18 352d6bd7d4e4aeb10feb59981afef3c1 *man/cholPosDef.Rd
19 9165996fd1830acfad9faa304e5190eb *man/fileexists.Rd
20 eda605d6cc8e92d2c2f6a0bb9efa7b94 *man/gauss.Rd
21 dc6965440125ce839f4d116f277fe336 *man/hostname.Rd
22 b91cc9fd0c3d30d3e6c3c993f7e67b15 *man/matern.Rd
23 c9954677c5143d1293a7ff7c6403358b *man/nonstwm.Rd
24 4415cc547bd340f4bca460df660fa55a *man/orderx.Rd
25 30f323fb4473b0ddada1160cb5af1e01 *man/sleep.Rd
26 a556c1215acedb06c7d095f2566672cd *man/solvePosDef.Rd
6 d4d9a5ea3af179120c5a13a3ab8a46a6 *R/utils.R
7 8bc5cc109f6020e329937494d79bbda0 *R/zzz.R
8 a4c1936053bf8061c75d19b2df494202 *inst/CITATION
9 a94df14046388069c8434c9c5e603ce5 *inst/include/AutoRandomFieldsUtils.h
10 a16620799274e01fb47324e1dc947429 *inst/include/AutoRandomFieldsUtilsLocal.h
11 aec542bed53c5a0153fe660631f0eb30 *inst/include/Basic_utils.h
12 3e7f2218d3ba9477b9e6b1c02f63164c *inst/include/General_utils.h
13 f83c81d89dd3109daedce037a2f105d0 *inst/include/Options_utils.h
14 25e6d56497be6184e3a18cb942141c14 *inst/include/Solve.h
15 fa73e3e9ee864047ae285688e6b79b0f *inst/include/Utils.h
16 009157c141313bd1eeb788e30fca386e *inst/include/errors_messages.h
17 cebd36533062167f03cc878060773627 *inst/include/intrinsics.h
18 44f7df73e37d588c057ddf5b23921d22 *inst/include/kleinkram.h
19 2fdabd899ac6fcc2cfad0bcfafcf1867 *inst/include/linear.h
20 804f4f26e0e99dc48ed918b8365621c1 *inst/include/local1.h
21 b391b123f7e859a22258d8285b1cf38e *inst/include/local2.h
22 fdadcc154117ace9d5c16f4f231f85d9 *inst/include/local3.h
23 f119027b153edd47d3abb4995974d531 *inst/include/scalar.h
24 5585429a87c484598dc0b8a1c411218e *inst/include/win_linux_aux.h
25 49d8e181d2d39eddbd74505c5c1781b3 *inst/include/zzz_RandomFieldsUtils.h
26 bc0a5ba4712537ba6b5fa4d238abe352 *inst/include/zzz_calls.h
27 702264e4df28c0b972848ddddbf9333c *man/Print.Rd
28 795c562ed2c07d29f3fbd1695ca327f4 *man/RFoptions.Rd
29 eaed6b6814863e79e2fd115ba9a11eb7 *man/Struve.Rd
30 52f9334a0204e9d7f484c4e767a98ec5 *man/cholPosDef.Rd
31 b2b145f200d3f632242cd0c6de5ff30c *man/confirm.Rd
32 e0df06020afe8fbb1ab382bfc53c5a8e *man/dbinorm.Rd
33 3da3eec69c71a9c8b6f25aa1cad343e3 *man/fileexists.Rd
34 646a9fd758f213350527b76086047e57 *man/gauss.Rd
35 81f967384af9708eb270b90742bc7db1 *man/hostname.Rd
36 d41d8cd98f00b204e9800998ecf8427e *man/macros/RFUoptions_defn.Rd
37 0b550bc3e9fe44e18de184563fa8bc2d *man/macros/allg_defn.Rd
38 d41d8cd98f00b204e9800998ecf8427e *man/macros/defn_RFUtiks.Rd
39 ab1560841c1f6891f568cf772c654e20 *man/matern.Rd
40 29d6209e206c03c19d333ce21077958c *man/nonstwm.Rd
41 d1aae9f8bcf5a0d2ffd370c2db7048ad *man/orderx.Rd
42 b733ff38b4cc886c645e687ea83393af *man/rowMeansx.Rd
43 b2cfc542e75708582e9f607f50ddb88a *man/sleep.Rd
44 b6d2e1aee07009be08585c7bfa1db0b1 *man/solvePosDef.Rd
2745 7034e7a90104522c8da4f95a536472de *man/sortx.Rd
28 f31accc274159145eed7d13ed2b58870 *src/Basic_utils.h
29 39598aef7112741a19221ed37181d83d *src/General_utils.h
30 d70143e9b9f31bbac4a3350515dfd9ee *src/Makevars
31 83ff926b36e383a5b4fd19bafc65d424 *src/Options_utils.h
32 2b7aa9d7586d84964d5f213f06208b50 *src/RFoptions.cc
33 de7ed03b4683a1c5192f8ecf60e951eb *src/RandomFieldsUtils.h
34 5c2fa3fdbde3b9e587dd4f5a7216a6cc *src/Solve.h
35 7ec47b2ed2f99f629a6f1f2329abc866 *src/bckslvmodified.f
36 bbf650f3e54ed72cc0f3ac61941ea2d3 *src/brdomain.cc
37 08a9f6c9da48a188df6c8c32fcdfa3d9 *src/cholmodified.f
38 e12b5af8ef95913d3e7f54c8ea94c448 *src/diffusion.cc
39 f3970e74b496a033cea94b92c9603de7 *src/errors_messages.h
40 9fce0515bfb67f6836cec2f3aaae3ff8 *src/init_RandomFieldsUtils.c
41 3b920f7dab7aa23f847475163ec7d649 *src/init_RandomFieldsUtils.h
42 40b298fc7899caf5be61fe393d2a308b *src/kleinkram.cc
43 994e648ba036ca9d2a62784c35fec0c4 *src/kleinkram.h
44 bc23d55d45e15fa7b799da55f5536853 *src/maths.cc
45 ac5ac679aeeb10e1ed1084b79566764d *src/options.cc
46 ddaa979904d3af73ee7e08bf309340a4 *src/own.cc
47 3bb97c6dfbe1c924dede5acbc7fdf202 *src/own.h
48 cbf60fdbd617f7586274b9e569cb6aaa *src/scalar.cc
49 0149871235c9b909f680ca9a34133a99 *src/solve.cc
50 893ac8d1d2990a623200bfcffc50b9f3 *src/sort.cc
51 3865607d016169fc2b8d7155f6e8fad4 *src/spamown.f
52 f7dc30f705872a48f0d6f5160d83b04a *src/utils.cc
53 0731d68aab70567cdd4b83337eaa6191 *src/win_linux_aux.cc
54 a74b10a955ed930d76095b58caf5e3ce *src/win_linux_aux.h
46 a94df14046388069c8434c9c5e603ce5 *src/AutoRandomFieldsUtils.h
47 a16620799274e01fb47324e1dc947429 *src/AutoRandomFieldsUtilsLocal.h
48 fb6a32fef37af8453a560a56c46ddf3e *src/Basic_utils.h
49 3e7f2218d3ba9477b9e6b1c02f63164c *src/General_utils.h
50 b839d8e710f1286f76201f97d98003d1 *src/Makevars
51 f83c81d89dd3109daedce037a2f105d0 *src/Options_utils.h
52 fc415be30ee3647902e458929c064964 *src/RFoptions.cc
53 e52acc94fee025e19a33cd530eb45ccb *src/RandomFieldsUtils.h
54 25e6d56497be6184e3a18cb942141c14 *src/Solve.h
55 fa73e3e9ee864047ae285688e6b79b0f *src/Utils.h
56 9403b6ee8cc2a8043458e693a56a53fc *src/bckslvmodified.f
57 d0667dc27316a9d13242284732f06000 *src/brdomain.cc
58 370f8ec5b7dca2091b47cfdf8ad13c06 *src/cholmodified.f
59 009157c141313bd1eeb788e30fca386e *src/errors_messages.h
60 cebd36533062167f03cc878060773627 *src/intrinsics.h
61 6d9d2571c97eaa818289a98c4a780077 *src/kleinkram.cc
62 fae28bb4476f143329dc7c9f9b11f467 *src/kleinkram.h
63 789a1e4cd9857df9153e08b3c4fdafc8 *src/linear.cc
64 2fdabd899ac6fcc2cfad0bcfafcf1867 *src/linear.h
65 9be3f0c0f6be9ca6972d3c6ba0f61ed0 *src/maths.cc
66 dd18cf06d80243a6f7877a9041615b9e *src/options.cc
67 f5561454c80e30f77c2f645110d89c4b *src/own.cc
68 b1383a54642176333d9a14c46089afd9 *src/own.h
69 3d4b514a98c577a52bb64ca653c95f31 *src/scalar.cc
70 f119027b153edd47d3abb4995974d531 *src/scalar.h
71 1bb89b6e66011876d94a69f6867a1318 *src/solve.cc
72 8f46b8b380ef5b4cc8f1e2ddb180d935 *src/sort.cc
73 9fe4550676b2491ebdf6d5f23df51e55 *src/spamown.f
74 7897c70a2aa36815ea1f388f3c5afad0 *src/utils.cc
75 39cd0d9fc791485cfa09266cadded9b6 *src/win_linux_aux.cc
76 5585429a87c484598dc0b8a1c411218e *src/win_linux_aux.h
77 b56f3a5e330d61203875674b71422c39 *src/zzz.c
78 49d8e181d2d39eddbd74505c5c1781b3 *src/zzz_RandomFieldsUtils.h
79 bc0a5ba4712537ba6b5fa4d238abe352 *src/zzz_calls.h
00
1
2 #exportPattern("^[^\\.]")
1 ###exportPattern("^[^\\.]")
32
43 export(cholx, cholPosDef, Print, solvex, solvePosDef,
54 sleep.milli, sleep.micro, hostname, pid, FileExists, LockRemove,
65 sortx, orderx,
76 gauss, I0L0, matern, nonstwm, struveH, struveL, whittle,
8 RFoptions)
7 RFoptions, confirm,
8 dbinorm,
9 colMax, rowMeansx, rowProd, SelfDivByRow, quadratic, dotXV,
10 chol2mv, tcholRHS)
11 exportPattern("^PIVOT_")
912
1013 useDynLib(RandomFieldsUtils, .registration = TRUE, .fixes = "C_")
1114 #useDynLib(spam)
1215
13 importFrom("utils", "str")
16 importFrom("utils", "str", "packageDescription", "contrib.url")
17 importFrom("methods", "hasArg", "is")
18 importFrom("grDevices", "dev.off")
1419
1520 S3method(print, RFopt)
1621 S3method(summary, RFopt)
00
11
2 summary.RFopt <- function(object, ...) {
2 summary.RFopt <- function(object, ...) {
33 object <- lapply(object, function(z) z[order(names(z))])
44 object <- object[c(1, 1 + order(names(object[-1])))]
55 class(object) <- "summary.RFopt"
3636 RFoptions <- function(..., no.readonly=TRUE) {
3737 ## on.exit(.C("RelaxUnknownRFoption", FALSE))
3838 ## .C("RelaxUnknownRFoption", TRUE)
39 opt <- lapply(.External(C_RFoptions, ...),
40 function(x) {
41 class(x) <- "RFoptElmnt"
42 x
43 })
44 if (length(opt)!=0) {
39 opt <- .External(C_RFoptions, ...)
40 if (length(opt) == 0) return(invisible(NULL))
41 if (is.list(opt[[1]])) {
42 opt <- lapply(opt,
43 function(x) {
44 class(x) <- "RFoptElmnt"
45 x
46 })
4547 class(opt) <- "RFopt"
46 if (!no.readonly) {
47 opt$readonly <- list()
48 }
48 } else class(opt) <- "RFoptElmnt"
49 if (!no.readonly) {
50 opt$readonly <- list()
4951 }
50 if (length(opt)==0) {
51 # O <- opt
52 # names(O) <- NULL
53 # opt <- c(opt, unlist(O))
54 invisible(opt)
55 } else opt
52 opt
5653 }
0 # This file has been created automatically by 'rfGenerateConstants'
1
2
3 ## from src/AutoRandomFieldsUtils.h
4
5
6
7 MAXUNITS <- as.integer(4)
8 MAXCHAR <- as.integer(18)
9 RFOPTIONS <- "RFoptions"
10 isGLOBAL <- as.integer(NA)
11
12
13
14
15
16 ## from src/AutoRandomFieldsUtilsLocal.h
17
18 PIVOT_NONE <- as.integer(0)
19 PIVOT_AUTO <- as.integer(1)
20 PIVOT_DO <- as.integer(2)
21 PIVOT_IDX <- as.integer(3)
22 PIVOT_UNDEFINED <- as.integer(4)
23 PIVOTLAST <- as.integer(PIVOT_UNDEFINED)
24
25 PIVOTSPARSE_MMD <- as.integer(1)
26 PIVOTSPARSE_RCM <- as.integer(2)
27
28
29
0
1 checkExamples <- function(exclude=NULL, include=1:length(.fct.list),
2 ask=FALSE, echo=TRUE, halt=FALSE, ignore.all=FALSE,
3 path=package, package="RandomFieldsUtils",
4 read.rd.files=TRUE,
5 libpath = NULL, single.runs = FALSE) {
6 .exclude <- exclude
7 .ask <- ask
8 .echo <- echo
9 .halt <- halt
10 .ignore.all <- ignore.all
11 .package <- package
12 .path <- path
13 useDynLib <- importClassesFrom <- import <-
14 importFrom <- exportClasses <-
15 importMethodsFrom <- exportMethods <- S3method <- function(...) NULL
16 .env <- new.env()
17 stopifnot(is.na(RFoptions()$basic$seed))
18
19 exportPattern <- function(p) { ## necessary to read NAMESPACE??!!
20 all.pattern <- p %in% c("^[^\\.]", "^[^.]", ".") | get("all.pattern", .env)
21 if (!.ignore.all) assign("all.pattern", all.pattern, .env)
22 if (all.pattern) return(NULL)
23 stopifnot(nchar(p)==2, substr(p,1,1)=="^")
24 assign("p", c(get("p", .env), substring(p, 2)), .env)
25 }
26
27 export <- function(...) {
28 ## code from 'rm'
29 dots <- match.call(expand.dots = FALSE)$...
30 z <-deparse(substitute(...))
31 if (length(dots) && !all(sapply(dots, function(x) is.symbol(x) ||
32 is.character(x))))
33 stop("... must contain names or character strings")
34 z <- sapply(dots, as.character)
35 assign("export", c(get("export", .env), z), .env)
36 }
37 assign("export", NULL, .env)
38 assign("all.pattern", FALSE, .env)
39 assign("p", NULL, .env)
40
41 source(paste(.path, "NAMESPACE", sep="/"), local=TRUE)
42 if (is.logical(read.rd.files) && !read.rd.files) {
43 .package.env <- parent.env(.GlobalEnv)
44 while (attr(.package.env, "name") != paste("package:", .package, sep="")) {
45 .package.env <- parent.env(.package.env)
46 }
47 .orig.fct.list <- ls(envir=.package.env)
48 .ok <- (get("all.pattern", .env) |
49 substr(.orig.fct.list, 1, 1) %in% get("p", .env) |
50 .orig.fct.list %in% get("export", .env))
51 .fct.list <- .orig.fct.list[.ok]
52 } else {
53 if (is.logical(read.rd.files))
54 .path <- paste("./", .path, "/man", sep="")
55 else .path <- read.rd.files
56 .files <- dir(.path, pattern="d$")
57 .fct.list <- character(length(.files))
58 for (i in 1:length(.files)) {
59 #cat(i, .path, .files[i], "\n")
60 #if (i == 152) {cat("jumped\n"); next}
61 #Print(.path, .files[i])
62 .content <- scan(paste(.path, .files[i], sep="/") , what=character(),
63 quiet=TRUE)
64 .content <- strsplit(.content, "alias\\{")
65 .content <- .content[which(lapply(.content, length) > 1)][[1]][2]
66 .fct.list[i] <-
67 strsplit(strsplit(.content,"\\}")[[1]][1], ",")[[1]][1]
68 }
69 }
70 .include <- include
71 .RFopt <- RFoptions()
72 .not_working_no <- .not_working <- NULL
73 .included.fl <- .fct.list[.include]
74 .not.isna <- !is.na(.included.fl)
75 .include <- .include[.not.isna]
76 .included.fl <- .included.fl[.not.isna]
77 .max.fct.list <- max(.included.fl)
78 if (single.runs) {
79 file.in <- "example..R"
80 file.out <- "example..Rout"
81 if (file.exists(file.out)) file.remove(file.out)
82 }
83
84 for (.idx in .include) {
85 try(repeat dev.off(), silent=TRUE)
86 if (.idx %in% .exclude) next
87 cat("\n\n\n\n\n", .idx, " ", .package, ":", .fct.list[.idx],
88 " (total=", length(.fct.list), ") \n", sep="")
89 RFoptions(LIST=.RFopt)
90 if (.echo) cat(.idx, "")
91 .tryok <- TRUE
92 if (single.runs) {
93 txt <- paste("library(", package,", ", libpath, "); example(",
94 .fct.list[.idx],
95 ", ask =", .ask,
96 ", echo =", .echo,
97 ")", sep="")
98 write(file=file.in, txt)
99 command <- paste("R < ", file.in, ">>", file.out)
100 } else {
101 ##stopifnot(RFoptions()$basic$print <=2 )
102 .time <- system.time(.res <- try(do.call(utils::example,
103 list(.fct.list[.idx],
104 ask=.ask, echo=.echo))))
105 if (is(.res, "try-error")) {
106 if (.halt) {
107 stop("\n\n\t***** ",.fct.list[.idx], " (", .idx,
108 "). has failed. *****\n\n")
109 } else {
110 .not_working_no <- c(.not_working_no, .idx)
111 .not_working <- c(.not_working, .fct.list[.idx])
112 .tryok <- FALSE
113 }
114 }
115 cat("****** '", .fct.list[.idx], "' (", .idx, ") done. ******\n")
116 print(.time)
117 }
118 }
119 Print(.not_working, paste(.not_working_no, collapse=", ")) #
120 .ret <- list(.not_working, .not_working_no)
121 names(.ret) <- c(.package, "")
122 return(.ret)
123 }
124
125
126 reverse_dependencies_with_maintainers <-
127 function(packages, which = c("Depends", "Imports", "LinkingTo"),
128 recursive = FALSE) {
129 ## function taken from CRAN developer website.
130 repos <- getOption("repos")["CRAN"]
131 ## if (substr(repos, 1, 1) == "@") repos <- "http://cran.r-project.org"
132 Print(repos) #
133 contrib.url(repos, "source") # trigger chooseCRANmirror() if required
134 description <- sprintf("%s/web/packages/packages.rds", repos)
135 con <- if(substring(description, 1L, 7L) == "file://")
136 file(description, "rb")
137 else
138 url(description, "rb")
139 on.exit(close(con))
140 db <- readRDS(gzcon(con))
141 rownames(db) <- NULL
142
143 rdepends <- tools::package_dependencies(packages, db, which,
144 recursive = recursive,
145 reverse = TRUE)
146 rdepends <- sort(unique(unlist(rdepends)))
147 pos <- match(rdepends, db[, "Package"], nomatch = 0L)
148
149 db <- db[pos, c("Package", "Version", "Maintainer")]
150 if (is.vector(db)) dim(db) <- c(1, length(db))
151 db
152 }
153
154 ShowInstallErrors <-
155 function(dir=".", pkgs=unlist(strsplit( dir(pattern="*.Rcheck"), ".Rcheck")))
156 for (i in 1:length(pkgs)) {
157 cat("\n\n", pkgs[i], "\n")
158 for (f in c("00install.out", "00check.log")) {
159 system(paste("grep [eE][rR][rR][oO][rR] ", dir, "/", pkgs[i],
160 ".Rcheck/", f, sep=""))
161 system(paste("grep \"user system elapsed\" -A 2 ", dir, "/", pkgs[i],
162 ".Rcheck/", f, sep=""))
163 ## system(paste("grep \"Warning messages\" -A 4 ", dir, "/", pkgs[i],
164 ## ".Rcheck/", f, sep=""))
165 ### find -type f -name "00*" -exec grep Warning {} \; -print
166 ### find -type f -name "00*" -exec grep "user system elapse" -A 3 {} \; -print
167
168
169 }
170 }
171
172
173
174 Dependencies <- function(pkgs = all.pkgs, dir = "Dependencies",
175 install = FALSE, check=TRUE, reverse=FALSE,
176 package="RandomFields") {
177 Print(utils::packageDescription(package)) #
178 all <- reverse_dependencies_with_maintainers(package #, which="Suggests")
179 , which="all")
180 all.pkgs <- all[, 1]
181 PKGS <- paste(all[,1], "_", all[,2], ".tar.gz", sep="")
182
183 ## getOption("repos")["CRAN"]
184 URL <- "http://cran.r-project.org/src/contrib/"
185
186 if (install) {
187 system(paste("mkdir ", dir))
188 system(paste("rm ", dir, "/*tar.gz*", sep=""))
189 for (i in 1:length(pkgs)) {
190 cat("PACKAGE:", PKGS[i], ":", i, "out of ", length(pkgs),"\n")
191 x <- system(paste("(cd ", dir, "; wget ", URL, PKGS[i], ")", sep=""))
192 if (x != 0) stop(PKGS[i], "not downloadable")
193 ## extended version see RandomFields V 3.0.51 or earlier
194 }
195 }
196 if (!hasArg("pkgs")) {
197 if (check) {
198 reverse <- if (reverse) list(repos = getOption("repos")["CRAN"]) else NULL
199 tools::check_packages_in_dir(dir=dir, check_args = c("--as-cran", ""),
200 reverse=reverse)
201 }
202 ShowInstallErrors(dir, pkgs)
203 return(NULL)
204 } else { ### old:
205 if (check) {
206 for (j in 1:length(pkgs)) {
207 i <- pmatch(pkgs[j], PKGS)
208 if (is.na(i)) next
209 command <- paste("(cd ", dir, "; time R CMD check --as-cran", PKGS[i],")")
210 Print(command) #
211 x <- system(command)
212 ShowInstallErrors(dir, pkgs)
213 if (x != 0) stop(PKGS[i], "failed")
214 }
215 }
216 }
217
218 }
219 # R Under development (unstable) (2014-12-09 r67142) -- "Unsuffered Consequences"
220
221
222 # Dependencies(check=FALSE)
7474 LockRemove <- function(file) {
7575 ## removes auxiliary files created by FileExists
7676 lock.ext <- ".lock";
77 file.remove(paste(file, lock.ext, sep=""))
77 file.remove(paste0(file, lock.ext))
7878 }
7979
8080
122122
123123
124124
125 cholx <- function(a) {
126 # return(.Call("Cholesky", a, PACKAGE="RandomFieldsUtils"))
127 .Call(C_Chol, a)
128 }
125 cholx <- function(a) .Call(C_Chol, a)
129126
130127 cholPosDef <- function() stop("please use 'cholx' instead of 'cholPosDef'.")
131128
132129 solvePosDef <- function(a, b=NULL, logdeterminant=FALSE) {
133130 stop("please use 'solvex' instead of 'solvePosDef'.")
134131 }
132
135133 solvex <- function(a, b=NULL, logdeterminant=FALSE) {
136134 if (logdeterminant) {
137135 logdet <- double(1)
180178
181179
182180 # scalar <- function(x, y, mode="1x1") .Call(C_scalarX, x, y, mode)
181
182
183 confirm <- function(x, y, ...) {
184 e <- all.equal(x, y, ...)
185 if (is.logical(e) && e) {
186 cat("'", deparse(substitute(x)) , "' and '", deparse(substitute(y)),
187 "' are the same.\n", sep="")
188 } else {
189 if (R.Version()$os=="linux-gnu") stop(e)
190 else {
191 message(x)
192 cat("(under linux systems they are the same.)")
193 return(FALSE)
194 }
195 }
196 }
197
198 chol2mv <- function(C, n) .Call(C_chol2mv, C, as.integer(n))
199 tcholRHS <- function(C, RHS) {
200 if (!is.double(RHS)) storage.mode(RHS) <- "double"
201 .Call(C_tcholRHS, C, RHS)
202 }
203 colMax <- function(x) .Call(C_colMaxs, x)
204 rowMeansx <- function(x, weight=NULL) .Call(C_rowMeansX, x, weight)
205 rowProd <- function(x) .Call(C_rowProd, x)
206 SelfDivByRow <- function(x, v) .Call(C_DivByRow, x, v)
207 quadratic <- function(x, v) .Call(C_quadratic, v, x)
208 dotXV <- function(x, w) .Call(C_dotXV, x, w)
209
210 dbinorm <- function(x, S) .Call(C_dbinorm, x, S)
00
11 .onLoad <- function(lib, pkg) {
2 .Call("attachRFoptionsUtils")
2 .Call("attachRandomFieldsUtils", interactive())
33 }
44
55 .onAttach <- function (lib, pkg) {
6 # packageStartupMessage("This is RandomFieldsUtils Version: 0.3.25");
6 # packageStartupMessage("This is RandomFieldsUtils Version: 0.5.3");
77 }
88
99 .onDetach <- function(lib) {
10 # .Call("detachRFoptionsUtils")
10 # .Call("detachRanodmFieldsUtils")
1111 }
1212
1313 .onUnload <- function(lib, pkg){
14 .Call("detachRFoptionsUtils")
14 .Call("detachRandomFieldsUtils")
1515 }
77 footer="",
88 title = "{RandomFieldsUtils}: Utilites for the Simulation and Analysis of Random Fields",
99 author = c(person("Martin", "Schlather", role=c("cre", "aut")),
10 person("Reinhard", "Furrer", role="ctb"),
11 person("Martin", "Kroll", role="ctb")),
10 person("Reinhard", "Furrer", role="ctb"),
11 person("Martin", "Kroll", role="ctb")),
12 person(given=c("Brian", "D"), "Ripley", role="ctb"),
1213 year = year,
1314 note = note,
1415 url = "https://cran.r-project.org/package=RandomFieldsUtils"
0 #ifndef auto_rfutils_h
1 #define auto_rfutils_h 1
2
3 #include "AutoRandomFieldsUtilsLocal.h"
4
5 #define MAXUNITS 4
6 #define MAXCHAR 18 // max number of characters for (covariance) names
7 #define RFOPTIONS "RFoptions"
8 #define isGLOBAL NA_INTEGER
9
10 #endif
0 #ifndef auto_rfutils_local_h
1 #define auto_rfutils_local_h 1
2
3 #define PIVOT_NONE 0
4 #define PIVOT_AUTO 1
5 #define PIVOT_DO 2
6 #define PIVOT_IDX 3 // IDX is not returned by RFoptions
7 #define PIVOT_UNDEFINED 4
8 #define PIVOTLAST PIVOT_UNDEFINED
9
10 #define PIVOTSPARSE_MMD 1 // for spam
11 #define PIVOTSPARSE_RCM 2 // for spam
12
13
14 #endif
0
1
2
30 /*
41 Authors
52 Martin Schlather, schlather@math.uni-mannheim.de
63
74
8 Copyright (C) 2015 Martin Schlather
5 Copyright (C) 2015 -- 2017 Martin Schlather
96
107 This program is free software; you can redistribute it and/or
118 modify it under the terms of the GNU General Public License
3128 #endif
3229 #include <R.h>
3330 #include <Rmath.h>
31 #include "AutoRandomFieldsUtils.h"
3432
33
34 #ifndef DO_PARALLEL_ALREADY_CONSIDERED
3535
3636 #ifdef _OPENMP
3737 #define DO_PARALLEL 1
4040 #undef DO_PARALLEL
4141 #endif
4242 #endif
43
44 #ifdef DO_PARALLEL
45 //#undef DO_PARALLEL
46 #endif
47
48
49 #endif // DO_PARALLEL_ALREADY_CONSIDERED
50
51
52 //#ifdef WIN32
53 //#ifdef DO_PARALLEL
54 //#undef DO_PARALLEL // make a comment to get parallel (part 1, see also part 2)
55 //#endif
56 //#endif
57
4358
4459 #define MULTIMINSIZE(S) ((S) > 20)
4560 // #define MULTIMINSIZE(S) false
5267
5368
5469 #define DOPRINT true
55 //
56 #define SCHLATHERS_MACHINE 1
70 //#define SCHLATHERS_MACHINE 1
5771
58 // // 1
72
5973 // #define HIDE_UNUSED_VARIABLE 1
6074
6175
6276 #ifdef __cplusplus
6377 extern "C" {
6478 #endif
65 // Fortran Code by Reinhard Furrer
6679 void spamcsrdns_(int*, double *, int *, int*, double*);
6780 void spamdnscsr_(int*, int*, double *, int*, double*, int*, int*, double*);
6881 void cholstepwise_(int*, int*, double*, int*, int*, int*, int*, int*,
98111 #define RF_INF R_PosInf
99112 #define T_PI M_2_PI
100113
101 #define MAXUNITS 4
102 #define MAXCHAR 18 // max number of characters for (covariance) names
103114 #define OBSOLETENAME "obsolete"
104 #define RFOPTIONS "RFoptions"
105115
106116 #define MAXINT 2147483647
117 #define MININT -2147483647
118 #define MAXUNSIGNED (MAXINT * 2) + 1
107119 #define INFDIM MAXINT
108120 #define INFTY INFDIM
109
110121
111122 #define LENGTH length // safety, in order not to use LENGTH defined by R
112123 #define complex Rcomplex
138149 #define MAX(A,B) ((A) > (B) ? (A) : (B))
139150
140151
141 #define ACOS(X) std::acos(X)
142 #define ASIN(X) std::asin(X)
143 #define ATAN(X) std::atan(X)
152 #define ACOS std::acos
153 #define ASIN std::asin
154 #define ATAN std::atan
144155 #define CEIL(X) std::ceil((double) X) // keine Klammern um X!
145 #define COS(X) std::cos(X)
146 #define EXP(X) std::exp(X)
156 #define COS std::cos
157 #define EXP std::exp
147158 #define FABS(X) std::fabs((double) X) // keine Klammern um X!
148 #define FLOOR(X) std::floor(X)
149 #define Log(X) std::log(X)
159 #define FLOOR std::floor
160 #define LOG std::log
150161 #define POW(X, Y) R_pow((double) X, (double) Y) // keine Klammern um X!
151 #define SIN(X) std::sin(X)
162 #define SIGN(X) sign((double) X)
163 #define SIN std::sin
152164 #define SQRT(X) std::sqrt((double) X)
153165 #define STRCMP(A, B) std::strcmp(A, B)
154166 #define STRCPY(A, B) std::strcpy(A, B)
155 #define STRLEN(X) std::strlen(X)
167 #define STRLEN std::strlen
156168 #define STRNCMP(A, B, C) std::strncmp(A, B, C)
157 #define TAN(X) std::tan(X)
169 #define STRNCPY(A, B, N) strcopyN(A, B, N)
170 #define TAN std::tan
158171 #define MEMCOPYX std::memcpy
172 #define MEMSET std::memset
173 #define AALLOC std::aligned_alloc
159174 #define CALLOCX std::calloc
160175 #define MALLOCX std::malloc
161176 #define FREEX std::free
162177 #define SPRINTF std::sprintf //
163 #define ROUND(X) std::round(X)
178 #define ROUND(X) ownround((double) X)
164179 #define TRUNC(X) ftrunc((double) X) // keine Klammern um X!
165180 #define QSORT std::qsort
166181
182
183 #define PRINTF Rprintf //
184 #ifdef SCHLATHERS_MACHINE
185 #ifdef DO_PARALLEL
186 #include <omp.h>
187 #undef PRINTF
188 #define PRINTF if (omp_get_num_threads() > 1) { error("\n\nnever use Rprintf/PRINTF within parallel constructions!!\n\n"); } else Rprintf // OK
167189 #endif
190 #endif
191
192 #define DOPRINTF if (!DOPRINT) {} else PRINTF
193 #define print NEVER_USE_print_or_PRINTF_WITHIN_PARALLEL /* // */
194
195
196 #endif
44 Martin Schlather, schlather@math.uni-mannheim.de
55
66
7 Copyright (C) 2015 Martin Schlather
7 Copyright (C) 2015 -- 2017 Martin Schlather
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
3434 #include "errors_messages.h"
3535 #include "kleinkram.h"
3636 #include "Solve.h"
37 #include "scalar.h"
3738
3839
39
40 #define DOPRINTF if (DOPRINT) Rprintf
41 #define PRINTF Rprintf
42 #define print PRINTF /* // */
4340
4441 #ifdef HIDE_UNUSED_VARIABLE
4542 #define VARIABLE_IS_NOT_USED __attribute__ ((unused))
5956 #define INTERNAL SERR("Sorry. This functionality does not exist currently. There is work in progress at the moment by the maintainer.")
6057 #define assert(X) {}
6158 #define BUG { \
62 SPRINTF(BUG_MSG, "Severe error occured in function '%s' (file '%s', line %d). Please contact maintainer martin.schlather@math.uni-mannheim.de .", \
59 RFERROR3("Severe error occured in function '%.50s' (file '%.50s', line %d). Please contact maintainer martin.schlather@math.uni-mannheim.de .", \
6360 __FUNCTION__, __FILE__, __LINE__); \
64 RFERROR(BUG_MSG); \
65 }
61 }
6662 #define DO_TESTS false
67 //#define MEMCOPY(A,B,C) {memcpy(A,B,C); printf("memcpy %s %d\n", __FILE__, __LINE__);}
63 //#define MEMCOPY(A,B,C) {MEMCPY(A,B,C); printf("memcpy %.50s %d\n", __FILE__, __LINE__);}
6864 #define MEMCOPY(A,B,C) MEMCOPYX(A,B,C)
65 #define AMALLOC(ELEMENTS, SIZE) AALLOC(SIZE, (SIZE) * (ELEMENTS))
6966 #define MALLOC MALLOCX
7067 #define CALLOC CALLOCX
68 #define XCALLOC CALLOCX
69 //
7170 #define FREE(X) if ((X) != NULL) {FREEX(X); (X)=NULL;}
71 //#define FREE(X) if ((X) != NULL) {printf("utils free %.50s %ld Line %d %s\n", #X, (long) X, __LINE__, __FILE__); FREEX(X); (X)=NULL;}
7272 #define UNCONDFREE(X) {FREEX(X); (X)=NULL;}
7373 #endif // not SCHLATHERS_MACHINE
7474
7979 #define MAXALLOC 1e9
8080
8181 // __extension__ unterdrueckt Fehlermeldung wegen geklammerter Argumente
82 #define INTERNAL \
83 SPRINTF(BUG_MSG, \
84 "made to be an internal function '%s' ('%s', line %d).", /* // */ \
85 __FUNCTION__, __FILE__, __LINE__); \
86 /* warning(BUG_MSG) */ \
87 SERR(BUG_MSG)
88
89 #define assert(X) if (!__extension__ (X)) { \
90 SPRINTF(BUG_MSG,"'assert(%s)' failed in function '%s'.",#X,__FUNCTION__); \
91 ERR(BUG_MSG); \
82 #define INTERNAL { \
83 RFERROR3("made to be an internal function '%.50s' ('%.50s', line %d).", \
84 __FUNCTION__, __FILE__, __LINE__); \
85 }
86
87 #define assert(X) if (!__extension__ (X)) { \
88 RFERROR3("'assert' failed in function '%.50s' (%.50s, line %d).", \
89 __FUNCTION__, __FILE__, __LINE__); \
9290 }
9391 #define SHOW_ADDRESSES 1
94 #define BUG { PRINTF("BUG in '%s'.", __FUNCTION__); ERR(BUG_MSG); }
92 #define BUG { RFERROR2("BUG in '%.50s' line %d.\n", __FUNCTION__, __LINE__);}
9593 #define DO_TESTS true
9694
97 #define MEMCOPY(A,B,C) __extension__ ({ assert((A)!=NULL && (B)!=NULL); MEMCOPYX(A,B,C); })
95 #define MEMCOPY(A,B,C) __extension__ ({ assert((A)!=NULL && (B)!=NULL && (C)>0 && (C)<=MAXALLOC); MEMCOPYX(A,B,C); })
9896 //#define MEMCOPY(A,B,C) memory_copy(A, B, C)
9997 #define MALLOC(X) __extension__ ({assert((X)>0 && (X)<=MAXALLOC); MALLOCX(X);})
10098 #define CALLOC(X, Y) __extension__({assert((X)>0 && (X)<=MAXALLOC && (Y)>0 && (Y)<=64); CALLOCX(X,Y);})
101 #define FREE(X) { if ((X) != NULL) {if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;}}
102 #define UNCONDFREE(X) { if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;}
99 #define XCALLOC(X, Y) __extension__({assert((X)>0 && (X)<=MAXALLOC && (Y)>0); CALLOCX(X,Y);})
100 #define FREE(X) { if ((X) != NULL) {if (showfree) { DOPRINTF("(free in %.50s, line %d)\n", __FILE__, __LINE__);} FREEX(X); (X)=NULL;}}
101 #define UNCONDFREE(X) { if (showfree) {DOPRINTF("(free in %.50s, line %d)\n", __FILE__, __LINE__);} FREEX(X); (X)=NULL;}
103102 #endif // SCHLATHERS_MACHINE
104103
105104
107106
108107 #ifdef RANDOMFIELDS_DEBUGGING
109108 #undef MALLOC
110 #define MALLOC(X) __extension__({DOPRINTF("(MALL %s, line %d)\n", __FILE__, __LINE__);assert((X)>0 && (X)<=3e9); MALLOCX(X);})
109 #define MALLOC(X) __extension__({DOPRINTF("(MLLC %.50s, line %d)\n", __FILE__, __LINE__);assert((X)>0 && (X)<=3e9); MALLOCX(X);})
111110 //
112111 #undef CALLOC
113 #define CALLOC(X, Y) __extension__({DOPRINTF("(CALL %s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)<MAXALLOC && (Y)>0 && (Y)<=64); CALLOCX(X,Y);})
112 #undef XCALLOC
113 #define CALLOC(X, Y) __extension__({DOPRINTF("(CLLC %.50s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)<MAXALLOC && (Y)>0 && (Y)<=216); CALLOCX(X,Y);})
114 #define XCALLOC(X, Y) __extension__({DOPRINTF("(CLLC %.50s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)<MAXALLOC && (Y)>0); CALLOCX(X,Y);})
114115 //#define MALLOC malloc
115116 //#define CALLOC calloc
116117
118
119 // note that DEBUGINDOERR is redefined in MachineDebugging.h
117120 #define DEBUGINFOERR { \
118 errorstring_type dummy_; strcpy(dummy_, ERRORSTRING); \
119 SPRINTF(ERRORSTRING, "%s (%s, line %d)\n", dummy_, __FILE__, __LINE__); \
121 errorstring_type dummy_; STRCPY(dummy_, WHICH_ERRORSTRING); \
122 SPRINTF(WHICH_ERRORSTRING, "%.50s (%.50s, line %d)\n", dummy_, __FILE__, __LINE__); \
120123 }
121 #define DEBUGINFO DOPRINTF("(currently at %s, line %d)\n", __FILE__, __LINE__)
124 #define DEBUGINFO DOPRINTF("(currently at %.50s, line %d)\n", __FILE__, __LINE__)
122125
123126 #else
124127 #define DEBUGINFO
125 #define DEBUGINFOERR if (PL >= PL_ERRORS) PRINTF("error: %s\n", ERRORSTRING);
128 #define DEBUGINFOERR if (PL >= PL_ERRORS) {PRINTF("error: %.50s\n", WHICH_ERRORSTRING);}
126129 #endif
127130
128131
132 extern int PLoffset;
129133 #define PL_IMPORTANT 1
130134 #define PL_BRANCHING 2
131135 #define PL_DETAILSUSER 3
142146 #define PL_SUBDETAILS 10
143147
144148 #define MATERN_NU_THRES 100
149 #define BESSEL_NU_THRES 100
150 #define LOW_MATERN 1e-20
151 #define LOW_BESSEL 1e-20
145152
146153
147154 #endif
148
149
44 Martin Schlather, schlather@math.uni-mannheim.de
55
66
7 Copyright (C) 2015 Martin Schlather
7 Copyright (C) 2015 -- 2017 Martin Schlather
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
3434
3535 #define R_PRINTLEVEL 1
3636 #define C_PRINTLEVEL 1
37 extern int PL;
37 #ifdef SCHLATHERS_MACHINE
38 #define INITCORES 4
39 #else
40 #define INITCORES 1
41 #endif
42
43 extern int PL, CORES;
3844
3945
4046 #define LEN_OPTIONNAME 201
4147
42 #define basicN 7
48 #define basicN 9
4349 // IMPORTANT: all names of basic must be at least 3 letters long !!!
4450 extern const char *basic[basicN];
4551 typedef struct basic_param {
46 bool
47 skipchecks,
48 asList;
4952 int
5053 Rprintlevel,
5154 Cprintlevel,
5255 seed, cores;
56 bool skipchecks, asList, kahanCorrection, helpinfo;
5357 } basic_param;
5458 #define basic_START \
55 { false, true, \
56 R_PRINTLEVEL, C_PRINTLEVEL, NA_INTEGER, 1 \
59 { R_PRINTLEVEL, C_PRINTLEVEL, NA_INTEGER, INITCORES, \
60 false, true, false, true \
5761 }
5862
5963
60 #define nr_InversionMethods ((int) Diagonal + 1)
61 #define nr_user_InversionMethods ((int) NoInversionMethod + 1)
6264 extern const char * InversionNames[nr_InversionMethods];
6365
64 #define PIVOT_NONE 0
65 #define PIVOT_MMD 1
66 #define PIVOT_RCM 2
6766 #define SOLVE_SVD_TOL 3
68 #define solveN 12
67 #define solveN 20
6968 typedef struct solve_param {
70 usr_bool sparse;
71 double spam_tol, spam_min_p, svd_tol, eigen2zero;
69 usr_bool sparse, pivot_check;
70 bool det_as_log;
71 double spam_tol, spam_min_p, svd_tol, eigen2zero, pivot_relerror,
72 max_deviation, max_reldeviation;
7273 InversionMethod Methods[SOLVE_METHODS];
73 int spam_min_n, spam_sample_n, spam_factor,
74 pivot, max_chol, max_svd;
74 int spam_min_n, spam_sample_n, spam_factor, pivotsparse, max_chol,
75 max_svd, pivot,
76 actual_pivot, actual_size,
77 *pivot_idx, pivot_idx_n;//permutation; phys+logi laenge
7578 // bool tmp_delete;
7679 } solve_param;
7780 #ifdef SCHLATHERS_MACHINE
7982 #else
8083 #define svd_tol_start 0
8184 #endif
82 #define solve_START \
83 { Nan, DBL_EPSILON, 0.8, svd_tol_start, 1e-12, \
84 {NoInversionMethod, NoInversionMethod}, \
85 400, 500, 4294967, PIVOT_MMD, 16384, 10000}
85 #define solve_START \
86 { Nan, False, true, \
87 DBL_EPSILON, 0.8, svd_tol_start, 1e-12, 1e-11, \
88 1e-10, 1e-10, \
89 {NoInversionMethod, NoFurtherInversionMethod}, \
90 400, 500, 4294967, PIVOTSPARSE_MMD, 16384, \
91 10000, PIVOT_NONE, /* never change -- see RFoptions.Rd */ \
92 PIVOT_UNDEFINED, 0, NULL, 0}
8693 extern const char * solve[solveN];
8794
8895
93100
94101
95102
96 typedef void (*setparameterfct) (int, int, SEXP, char[200], bool);
97 typedef void (*getparameterfct) (SEXP*);
98 typedef void (*finalsetparameterfct) ();
99 #define ADD(ELT) SET_VECTOR_ELT(sublist[i], k++, ELT);
103 typedef void (*setparameterfct) (int, int, SEXP, char[200], bool, int);
104 typedef void (*getparameterfct) (SEXP, int, int);
105 typedef void (*finalsetparameterfct) (int);
106 typedef void (*deleteparameterfct) (int);
107 #define ADD(ELT) SET_VECTOR_ELT(sublist, k++, ELT);
100108 #define ADDCHAR(ELT) x[0] = ELT; ADD(ScalarString(mkChar(x)));
101109
102110
22 Martin Schlather, schlather@math.uni-mannheim.de
33
44
5 Copyright (C) 2015 Martin Schlather
5 Copyright (C) 2015 -- 2017 Martin Schlather
66
77 This program is free software; you can redistribute it and/or
88 modify it under the terms of the GNU General Public License
1919 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
2020 */
2121
22
22 #include "errors_messages.h"
2323
2424 #ifndef rfutils_solve_H
2525 #define rfutils_solve_H 1
3333 direct_formula,
3434 Diagonal // always last one!
3535 } InversionMethod;
36 #define nr_InversionMethods ((int) Diagonal + 1)
37 #define nr_user_InversionMethods ((int) NoFurtherInversionMethod + 1)
3638
3739
3840 #define SOLVE_METHODS 3
3941 typedef struct solve_storage {
42 errorstring_type err_msg;
43 InversionMethod method, newMethods[SOLVE_METHODS];
44 usr_bool sparse;
4045 int SICH_n, MM_n, workspaceD_n, workspaceU_n, VT_n, U_n, D_n,
41 iwork_n, work_n, w2_n, ipiv_n, workLU_n, pivot_n,
46 iwork_n, work_n, w2_n, ipiv_n, workLU_n, pivotsparse_n,
4247 xlnz_n, snode_n, xsuper_n, xlindx_n, invp_n,
4348 cols_n, rows_n, DD_n, lindx_n, xja_n,
44 lnz_n, w3_n, result_n;
45 //t_cols_n, t_rows_n, t_DD_n;
46 InversionMethod method, newMethods[SOLVE_METHODS];
47 int nsuper, nnzlindx, size,
49 diagonal_n,
50 lnz_n, w3_n, result_n,
51 nsuper, nnzlindx, size, actual_size, actual_pivot,
52 *pivot_idx, pivot_idx_n,
4853 *iwork, *ipiv,
49 *pivot, *xlnz, *snode, *xsuper, *xlindx,
54 *pivotsparse, *xlnz, *snode, *xsuper, *xlindx,
5055 *invp, *cols, *rows, *lindx, *xja; //*t_cols, *t_rows;
5156 double *SICH, *MM, *workspaceD, *workspaceU,
52 *VT, *work, *w2, *U, *D, *workLU,
57 *VT, *work, *w2, *U, *D, *workLU, *diagonal,
5358 *lnz, *DD, *w3, *result,
5459 *to_be_deleted; //, *t_DD;
5560 } solve_storage;
5661
57
58
59
62 #define SOLVE 0
63 #define MATRIXSQRT 1
64 #define DETERMINANT 2
6065
6166 #endif
0 /*
1 Authors
2 Martin Schlather, schlather@math.uni-mannheim.de
3
4
5 Copyright (C) 2018 -- 2018 Martin Schlather
6
7 This program is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public License
9 as published by the Free Software Foundation; either version 3
10 of the License, or (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20 */
21
22
23 #ifndef rfutils_utils_H
24 #define rfutils_utils_H 1
25
26 extern bool ToFalse[1];
27 double *ToReal(SEXP X);
28 int *ToInt(SEXP X);
29 //double *ToRealI(SEXP X, bool *create);
30
31
32 #ifdef __cplusplus
33 extern "C" {
34 #endif
35 int *ToIntI(SEXP X, bool *create, bool round);
36 void freeGlobals();
37 // double *ToRealI(SEXP X, bool *create);
38 // int *ToIntI(SEXP X, bool *create, bool round);
39 #ifdef __cplusplus
40 }
41 #endif
42
43
44
45 #endif
44 Martin Schlather, schlather@math.uni-mannheim.de
55
66
7 Copyright (C) 2015 Martin Schlather
7 Copyright (C) 2015 -- 2017 Martin Schlather
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
3131 #define NOERROR 0
3232 #define ERRORMEMORYALLOCATION 1
3333 #define ERRORFAILED 2 /* method didn't work for the specified parameters */
34 #define ERRORM 3 /* a single error message */
35 #define ERRORNOTPROGRAMMEDYET 4
36
34 #define ERRORNOTPROGRAMMEDYET 3
35 #define ERRORM 4 /* a single error message */
36 #define ERRORMEND 12 /* a single error message -- und alles dazwischen */
3737
3838
39 #ifdef SCHLATHERS_MACHINE
40 #define ERRLINE PRINTF("(ERROR in %s, line %d)\n", __FILE__, __LINE__);
41 #else
42 #define ERRLINE
43 #endif
44
45
46 #define LENMSG 250
39
40 #define LENMSG 1000
4741 #define MAXERRORSTRING 1000
4842 #define nErrorLoc 1000
49 #define LENERRMSG 2000
43 #define LENERRMSG 1000
5044 typedef char errorstring_type[MAXERRORSTRING];
5145 typedef char errorloc_type[nErrorLoc];
46
47
48 #ifdef DO_PARALLEL
49 #define LOCAL_ERRMSG2 char MSG2[LENERRMSG]
50 #ifndef LOCAL_ERRLOC_MSG
51 #define LOCAL_ERRLOC_MSG errorloc_type ERROR_LOC=""; char ERRMSG[LENERRMSG];
52 #endif
53 #ifndef LOCAL_ERRORSTRING
54 #define LOCAL_ERRORSTRING errorstring_type ERRORSTRING
55 #endif
56
57 #else // not DO_PARALLEL
58
59 #define LOCAL_ERRMSG2
60 #ifndef LOCAL_ERRLOC_MSG
61 #define LOCAL_ERRLOC_MSG
62 #endif
63 #ifndef LOCAL_ERRORSTRING
64 #define LOCAL_ERRORSTRING
65 #endif
5266 extern char ERRMSG[LENERRMSG], // used by Error_utils.h. Never use elsewhere
53 MSG[LENERRMSG], // used by RandomFields in intermediate steps
54 BUG_MSG[LENMSG],// not much used
5567 MSG2[LENERRMSG];// used at the same time with MSG and ERR()
56 extern errorstring_type ERRORSTRING; // used by ERRORM in RandomFields
68 extern errorstring_type ERRORSTRING; // used by ERRORM in RandomFields
69
70 #ifndef ERROR_LOC
5771 extern errorloc_type ERROR_LOC;
58
59 #define ERRMSG(X) if (PL>=PL_ERRORS){errorMSG(X,MSG); PRINTF("error: %s%s\n",ERROR_LOC,MSG);}
72 #endif
73 // extern char MSG[LENERRMSG]; // used by RandomFields in intermediate steps
74 #endif
75
76 #endif
77
78 #ifndef WHICH_ERRORSTRING
79 #define WHICH_ERRORSTRING ERRORSTRING
80 #endif
81
82 #ifndef LOCAL_ERROR
83 #define LOCAL_ERROR(N) {}
84 #endif
85
86
87 // #define ERRMSG(X) if (PL>=PL_ERRORS){errorMSG(X,MSG); PRINTF("error: %.50s%.50s\n",ERROR_LOC,MSG);}
88
89
90
91 #ifdef SCHLATHERS_MACHINE
92 #define ERRLINE0 PRINTF("(ERROR in %.50s, line %d)\n", __FILE__, __LINE__); LOCAL_ERRLOC_MSG
93 //#define ERRLINE ERRLINE0; LOCAL_ERRMSG2
94 #else
95 #define ERRLINE0 LOCAL_ERRLOC_MSG
96 #endif
97 #define ERRLINE ERRLINE0; LOCAL_ERRMSG2
98
99
100 #define W_ERRLINE0 char W_ERRMSG[LENERRMSG]
101 #define W_ERRLINE char W_MSG2[LENERRMSG]
60102
61103
62104 #define RFERROR error
63 #define ERR(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFERROR(ERRMSG);}
64 #define ERR1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
65 SPRINTF(MSG2, ERRMSG, Y); \
66 RFERROR(MSG2);}
67 #define ERR2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\
68 SPRINTF(MSG2, ERRMSG, Y, Z); \
69 RFERROR(MSG2);}
70 #define ERR3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
71 SPRINTF(MSG2, ERRMSG, Y, Z, A); \
72 RFERROR(MSG2);}
73 #define ERR4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
74 SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \
75 RFERROR(MSG2);}
76 #define ERR5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \
77 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \
78 RFERROR(MSG2);}
79 #define ERR6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
80 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \
81 RFERROR(MSG2);}
82 #define ERR7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
83 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \
84 RFERROR(MSG2);}
85 #define ERR8(X,Y,Z,A,B,C,D,E,F) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
86 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E, F); \
87 RFERROR(MSG2);}
88 #define FERR(X) strcpy(ERRORSTRING, X); DEBUGINFOERR
89 #define SERR(X) { FERR(X); return ERRORM;}
90 #define CERR(X) { FERR(X); err=ERRORM; continue;}
91 #define FERR1(X,Y) SPRINTF(ERRORSTRING, X, Y); DEBUGINFOERR
92 #define SERR1(X,Y) { FERR1(X, Y); return ERRORM;}
93 #define CERR1(X,Y) { FERR1(X, Y); err=ERRORM; continue; }
94 #define FERR2(X,Y,Z) SPRINTF(ERRORSTRING, X, Y, Z); DEBUGINFOERR
95 #define SERR2(X, Y, Z) { FERR2(X, Y, Z); return ERRORM;}
96 #define CERR2(X, Y, Z) { FERR2(X, Y, Z); err=ERRORM; continue;}
97 #define FERR3(X,Y,Z,A) SPRINTF(ERRORSTRING, X, Y, Z, A); DEBUGINFOERR
98 #define SERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); return ERRORM;}
99 #define CERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); err=ERRORM; continue;}
100 #define FERR4(X,Y,Z,A,B) SPRINTF(ERRORSTRING, X, Y, Z, A, B); DEBUGINFOERR
101 #define SERR4(X, Y, Z, A, B) { FERR4(X, Y, Z, A, B); return ERRORM;}
102 #define FERR5(X,Y,Z,A,B,C) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C); DEBUGINFOERR
103 #define SERR5(X, Y, Z, A, B, C) {FERR5(X, Y, Z, A, B, C); return ERRORM;}
104 #define FERR6(X,Y,Z,A,B,C,D) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D); DEBUGINFOERR
105 #define SERR6(X, Y, Z, A, B, C, D) {FERR6(X, Y, Z, A, B, C,D); return ERRORM;}
106 #define FERR7(X,Y,Z,A,B,C,D,E) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D,E);DEBUGINFOERR
107 #define SERR7(X, Y, Z, A, B, C, D, E) {FERR7(X,Y,Z,A,B,C,D,E); return ERRORM;}
108 #define GERR(X) {FERR(X); err = ERRORM; goto ErrorHandling;}
109 #define GERR1(X,Y) {FERR1(X,Y);err = ERRORM; goto ErrorHandling;}
110 #define GERR2(X,Y,Z) {FERR2(X,Y,Z); err = ERRORM; goto ErrorHandling;}
111 #define GERR3(X,Y,Z,A) {FERR3(X,Y,Z,A); err = ERRORM; goto ErrorHandling;}
112 #define GERR4(X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); err = ERRORM; goto ErrorHandling;}
113 #define GERR5(X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); err=ERRORM; goto ErrorHandling;}
114 #define GERR6(X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); err=ERRORM; goto ErrorHandling;}
105 #define ERR(X) {ERRLINE0;SPRINTF(ERRMSG, "%.90s %.790s",ERROR_LOC,X);RFERROR(ERRMSG);}
106 #define ERR00(X) ERRLINE;SPRINTF(ERRMSG, "%.90s %.790s", ERROR_LOC, X)
107 #define ERR1(X, Y) {ERR00(X); SPRINTF(MSG2, ERRMSG, Y); RFERROR(MSG2);}
108 #define ERR2(X, Y, Z) {ERR00(X); SPRINTF(MSG2, ERRMSG, Y, Z); RFERROR(MSG2);}
109 #define ERR3(X, Y, Z, A) {ERR00(X); SPRINTF(MSG2, ERRMSG,Y,Z,A); RFERROR(MSG2);}
110 #define ERR4(X, Y, Z, A, B) {ERR00(X); SPRINTF(MSG2,ERRMSG,Y,Z,A,B); \
111 RFERROR(MSG2);}
112 #define ERR5(X, Y, Z, A, B, C) {ERR00(X); SPRINTF(MSG2, ERRMSG,Y,Z,A,B,C); \
113 RFERROR(MSG2);}
114 #define ERR6(X, Y, Z, A, B,C,D) {ERR00(X); SPRINTF(MSG2, ERRMSG,Y,Z,A,B,C,D); \
115 RFERROR(MSG2);}
116 #define ERR7(X, Y, Z,A,B,C,D,E) {ERR00(X); SPRINTF(MSG2,ERRMSG,Y,Z,A,B,C,D,E); \
117 RFERROR(MSG2);}
118 #define ERR8(X,Y,Z,A,B,C,D,E,F){ERR00(X);SPRINTF(MSG2,ERRMSG,Y,Z,A,B,C,D,E,F); \
119 RFERROR(MSG2);}
120
121 #define FERR(X) LOCAL_ERRORSTRING; STRCPY(WHICH_ERRORSTRING, X); DEBUGINFOERR
122 #define FERR1(X,Y) LOCAL_ERRORSTRING; \
123 SPRINTF(WHICH_ERRORSTRING, X, Y); DEBUGINFOERR
124 #define FERR2(X,Y,Z) LOCAL_ERRORSTRING; \
125 SPRINTF(WHICH_ERRORSTRING, X, Y, Z); DEBUGINFOERR
126 #define FERR3(X,Y,Z,A) LOCAL_ERRORSTRING; \
127 SPRINTF(WHICH_ERRORSTRING, X, Y, Z, A); DEBUGINFOERR
128 #define FERR4(X,Y,Z,A,B) LOCAL_ERRORSTRING; \
129 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B); DEBUGINFOERR
130 #define FERR5(X,Y,Z,A,B,C) LOCAL_ERRORSTRING; \
131 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B,C); DEBUGINFOERR
132 #define FERR6(X,Y,Z,A,B,C,D) LOCAL_ERRORSTRING; \
133 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B,C,D); DEBUGINFOERR
134 #define FERR7(X,Y,Z,A,B,C,D,E) LOCAL_ERRORSTRING; \
135 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B,C,D,E); DEBUGINFOERR
136
137 #define NERR00(N) LOCAL_ERROR(N); return N;
138 #define NERR(N,X) {FERR(X); NERR00(N)}
139 #define NERR1(N,X,Y) { FERR1(X, Y); NERR00(N)}
140 #define NERR2(N,X, Y, Z) { FERR2(X, Y, Z); NERR00(N)}
141 #define NERR3(N,X, Y, Z, A) { FERR3(X, Y, Z, A); NERR00(N)}
142 #define NERR4(N,X, Y, Z, A, B) { FERR4(X, Y, Z, A, B); NERR00(N)}
143 #define NERR5(N,X, Y, Z, A, B, C) { FERR5(X, Y, Z, A, B, C); NERR00(N)}
144 #define NERR6(N,X, Y, Z, A, B, C, D) { FERR6(X, Y, Z, A,B,C,D); NERR00(N)}
145 #define NERR7(N,X,Y,Z, A, B, C, D, E) { FERR7(X,Y,Z,A,B,C,D,E); NERR00(N)}
146
147 #define SERR(X) NERR(ERRORM, X)
148 #define SERR1(X,Y) NERR1(ERRORM, X, Y)
149 #define SERR2(X,Y,Z) NERR2(ERRORM, X, Y, Z)
150 #define SERR3(X,Y,Z, A) NERR3(ERRORM, X, Y, Z, A)
151 #define SERR4(X,Y,Z, A, B) NERR4(ERRORM, X, Y, Z, A, B)
152 #define SERR5(X,Y,Z, A, B, C) NERR5(ERRORM, X, Y, Z, A, B, C)
153 #define SERR6(X,Y,Z, A, B, C, D) NERR6(ERRORM, X, Y, Z, A, B, C, D)
154 #define SERR7(X,Y,Z, A, B, C, D, E) NERR7(ERRORM, X, Y, Z, A, B, C, D, E)
155
156 #define CERR00 err=ERRORM; continue;
157 #define CERR(X) { FERR(X); CERR00}
158 #define CERR1(X,Y) { FERR1(X, Y); CERR00}
159 #define CERR2(X, Y, Z) { FERR2(X, Y, Z); CERR00}
160 #define CERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); CERR00}
161
162
163 #define GERR00 LOCAL_ERROR(ERRORM); err = ERRORM; goto ErrorHandling;
164 #define GERR(X) {FERR(X); GERR00}
165 #define GERR1(X,Y) {FERR1(X,Y); GERR00}
166 #define GERR2(X,Y,Z) {FERR2(X,Y,Z); GERR00}
167 #define GERR3(X,Y,Z,A) {FERR3(X,Y,Z,A); GERR00}
168 #define GERR4(X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); GERR00}
169 #define GERR5(X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); GERR00}
170 #define GERR6(X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); GERR00}
171
172 #define GNERR00(N) err = N; goto ErrorHandling;
173 #define GNERR(N,X) {FERR(X); GNERR00(N)}
174 #define GNERR1(N,X,Y) {FERR1(X,Y);GNERR00(N)}
175 #define GNERR2(N,X,Y,Z) {FERR2(X,Y,Z); GNERR00(N)}
176 #define GNERR3(N,X,Y,Z,A) {FERR3(X,Y,Z,A); GNERR00(N)}
177 #define GNERR4(N,X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); GNERR00(N)}
178 #define GNERR5(N,X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); GNERR00(N)}
179 #define GNERR6(N,X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); GNERR00(N)}
115180
116181 #define RFWARNING warning
117 #define warn(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFWARNING(ERRMSG);}
118 #define WARN1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
119 SPRINTF(MSG2, ERRMSG, Y); \
120 RFWARNING(MSG2);}
121 #define WARN2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\
122 SPRINTF(MSG2, ERRMSG, Y, Z); \
123 RFWARNING(MSG2);}
124 #define WARN3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
125 SPRINTF(MSG2, ERRMSG, Y, Z, A); \
126 RFWARNING(MSG2);}
127 #define WARN4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
128 SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \
129 RFWARNING(MSG2);}
130 #define WARN5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \
131 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \
132 RFWARNING(MSG2);}
133 #define WARN6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
134 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \
135 RFWARNING(MSG2);}
136 #define WARN7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
137 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \
138 RFWARNING(MSG2);}
139
140
141 #endif
182 #define warn(X) {RFWARNING(X);}
183 #define WARN0 warn
184 #define WARN1(X, Y) {W_ERRLINE; \
185 SPRINTF(W_MSG2, X, Y); RFWARNING(W_MSG2);}
186 #define WARN2(X, Y, Z) {W_ERRLINE; \
187 SPRINTF(W_MSG2, X, Y, Z); RFWARNING(W_MSG2);}
188 #define WARN3(X, Y, Z, A) {W_ERRLINE;\
189 SPRINTF(W_MSG2, X, Y, Z, A); RFWARNING(W_MSG2);}
190 #define WARN4(X, Y, Z, A, B) {W_ERRLINE; \
191 SPRINTF(W_MSG2, X, Y, Z, A, B); RFWARNING(W_MSG2);}
192 #define WARN5(X, Y, Z, A, B, C) {W_ERRLINE; \
193 SPRINTF(W_MSG2, X, Y, Z, A, B, C); RFWARNING(W_MSG2);}
194 #define WARN6(X, Y, Z, A, B,C,D) {W_ERRLINE; \
195 SPRINTF(W_MSG2, X, Y, Z, A, B, C, D); RFWARNING(W_MSG2);}
196 #define WARN7(X, Y, Z,A,B,C,D,E) {W_ERRLINE; \
197 SPRINTF(W_MSG2, X, Y, Z, A, B, C, D, E); RFWARNING(W_MSG2);}
198
199
200 #define RFERROR1(M,A) {errorstring_type ERR_STR; \
201 SPRINTF(ERR_STR, M, A); RFERROR(ERR_STR);}
202 #define RFERROR2(M,A,B) {errorstring_type ERR_STR; \
203 SPRINTF(ERR_STR, M, A,B); RFERROR(ERR_STR);}
204 #define RFERROR3(M,A,B,C) {errorstring_type ERR_STR;\
205 SPRINTF(ERR_STR, M, A,B,C); RFERROR(ERR_STR);}
206 #define RFERROR4(M,A,B,C,D) {errorstring_type ERR_STR; \
207 SPRINTF(ERR_STR, M, A,B,C,D); RFERROR(ERR_STR);}
208 #define RFERROR5(M,A,B,C,D,E) {errorstring_type ERR_STR; \
209 SPRINTF(ERR_STR, M, A,B,C,D,E); RFERROR(ERR_STR);}
210 #define RFERROR6(M,A,B,C,D,E,F) {errorstring_type ERR_STR;\
211 SPRINTF(ERR_STR, M, A,B,C,D,E,F); RFERROR(ERR_STR);}
212 #define RFERROR7(M,A,B,C,D,E,F,G) {errorstring_type ERR_STR;\
213 SPRINTF(ERR_STR, M, A,B,C,D,E,F,G); RFERROR(ERR_STR);}
+0
-212
inst/include/init_RandomFieldsUtils.h less more
0
1
2
3 /*
4 Authors
5 Martin Schlather, schlather@math.uni-mannheim.de
6
7
8 Copyright (C) 2015 Martin Schlather
9
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 3
13 of the License, or (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 */
24
25 #ifndef rfutils_init_H
26 #define rfutils_init_H 1
27
28 #include "Options_utils.h"
29 #include "errors_messages.h"
30
31
32
33 #ifdef HAVE_VISIBILITY_ATTRIBUTE
34 # define attribute_hidden __attribute__ ((visibility ("hidden")))
35 #else
36 # define attribute_hidden
37 #endif
38
39 #ifdef __cplusplus
40 extern "C" {
41 #endif
42
43 #define RF_UTILS "RandomFieldsUtils"
44 //#define FCT_PREFIX RU_
45 #define CALL0(V, N) \
46 V attribute_hidden RU_##N() { \
47 static V(*fun)(AV) = NULL; \
48 if (fun == NULL) fun = (V (*) ()) R_GetCCallable(RF_UTILS, #N); \
49 return fun(); }
50 #define DECLARE0(V, N) \
51 typedef V (*N##_type)(); \
52 /* extern N##_type Ext_##N; */ \
53 V attribute_hidden RU_##N(); \
54 V N();
55
56 #define CALL1(V, N, AV, AN) \
57 /* N##_type Ext_##N = NULL; */ \
58 V attribute_hidden RU_##N(AV AN) { \
59 static N##_type fun = NULL; \
60 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
61 return fun(AN); }
62 #define DECLARE1(V, N, AV, AN) \
63 typedef V (*N##_type)(AV AN); \
64 /* extern N##_type Ext_##N; */ \
65 V attribute_hidden RU_##N(AV AN); \
66 V N(AV AN);
67
68 #define CALL2(V, N, AV, AN, BV, BN) \
69 /* N##_type Ext_##N = NULL; */ \
70 V attribute_hidden RU_##N(AV AN, BV BN) { \
71 static N##_type fun = NULL; \
72 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
73 return fun(AN, BN); }
74 #define DECLARE2(V, N, AV, AN, BV, BN) \
75 typedef V (*N##_type)(AV AN, BV BN); \
76 /* extern N##_type Ext_##N; */ \
77 V attribute_hidden RU_##N(AV AN, BV BN); \
78 V N(AV AN, BV BN);
79
80 #define CALL3(V, N, AV, AN, BV, BN, CV, CN) \
81 /* N##_type Ext_##N = NULL; */ \
82 V attribute_hidden RU_##N(AV AN, BV BN, CV CN) { \
83 static N##_type fun = NULL; \
84 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
85 return fun(AN, BN, CN); }
86 #define DECLARE3(V, N, AV, AN, BV, BN, CV, CN) \
87 typedef V (*N##_type)(AV AN, BV BN, CV CN); \
88 /* extern N##_type Ext_##N; */ \
89 V attribute_hidden RU_##N(AV AN, BV BN, CV CN); \
90 V N(AV AN, BV BN, CV CN);
91
92 #define CALL4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
93 /* N##_type Ext_##N = NULL; */ \
94 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN) { \
95 static N##_type fun = NULL; \
96 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
97 return fun(AN, BN, CN, DN); }
98 #define DECLARE4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
99 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN); \
100 /* extern N##_type Ext_##N; */ \
101 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN); \
102 V N(AV AN, BV BN, CV CN, DV DN);
103
104 #define CALL5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
105 /* N##_type Ext_##N = NULL; */ \
106 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN) { \
107 static N##_type fun = NULL; \
108 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
109 return fun(AN, BN, CN, DN, EN); }
110 #define DECLARE5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
111 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN); \
112 /* extern N##_type Ext_##N; */ \
113 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN); \
114 V N(AV AN, BV BN, CV CN, DV DN, EV EN);
115
116 #define CALL6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
117 /* N##_type Ext_##N = NULL; */ \
118 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN) { \
119 static N##_type fun = NULL; \
120 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
121 return fun(AN, BN, CN, DN, EN, FN); }
122 #define DECLARE6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
123 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
124 /* extern N##_type Ext_##N; */ \
125 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
126 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN);
127
128 #define CALL7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
129 /* N##_type Ext_##N = NULL; */ \
130 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN) { \
131 static N##_type fun = NULL; \
132 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
133 return fun(AN, BN, CN, DN, EN, FN, GN); }
134 #define DECLARE7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
135 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
136 /* extern N##_type Ext_##N; */ \
137 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
138 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN);
139
140 #define CALL8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
141 /* N##_type Ext_##N = NULL; */ \
142 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN) { \
143 static N##_type fun = NULL; \
144 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
145 return fun(AN, BN, CN, DN, EN, FN, GN, HN); }
146 #define DECLARE8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
147 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
148 /* extern N##_type Ext_##N; */ \
149 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
150 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN);
151
152
153 DECLARE1(void, solve_DELETE, solve_storage**, S)
154 DECLARE1(void, solve_NULL, solve_storage*, x)
155 DECLARE7(int, solvePosDef, double*, M, int, size, bool, posdef,
156 double *, rhs, int, rhs_cols, double *, logdet, solve_storage *, PT)
157 DECLARE8(int, solvePosDefResult, double*, M, int, size, bool, posdef,
158 double *, rhs, int, rhs_cols, double *, result, double*, logdet,
159 solve_storage*, PT)
160 DECLARE3(int, sqrtPosDef, double *, M, int, size, solve_storage *, pt)
161 DECLARE3(int, sqrtPosDefFree, double *, M, int, size, solve_storage *, pt)
162 DECLARE3(int, sqrtRHS, solve_storage *, pt, double*, RHS, double *, res)
163 DECLARE2(int, invertMatrix, double *, M, int, size)
164 DECLARE2(double, StruveH, double, x, double, nu)
165 DECLARE3(double, StruveL, double, x, double, nu, bool, expScaled)
166 DECLARE1(double, I0mL0, double, x)
167 DECLARE3(double, WM, double, x, double, nu, double, factor)
168 DECLARE3(double, DWM, double, x, double, nu, double, factor)
169 DECLARE3(double, DDWM, double, x, double, nu, double, factor)
170 DECLARE3(double, D3WM, double, x, double, nu, double, factor)
171 DECLARE3(double, D4WM, double, x, double, nu, double, factor)
172 DECLARE4(double, logWM, double, x, double, nu1, double, nu2, double, factor)
173 DECLARE1(double, Gauss, double, x)
174 DECLARE1(double, DGauss, double, x)
175 DECLARE1(double, DDGauss, double, x)
176 DECLARE1(double, D3Gauss, double, x)
177 DECLARE1(double, D4Gauss, double, x)
178 DECLARE1(double, logGauss, double, x)
179
180 DECLARE1(void, getErrorString, errorstring_type, errorstring)
181 DECLARE1(void, setErrorLoc, errorloc_type, errorloc)
182 DECLARE1(void, getUtilsParam, utilsparam **, up)
183 DECLARE7(void, attachRFoptions, const char **, prefixlist, int, N,
184 const char ***, all, int *, allN, setparameterfct, set,
185 finalsetparameterfct, final, getparameterfct, get)
186 DECLARE2(void, detachRFoptions, const char **, prefixlist, int, N)
187 DECLARE1(void, relaxUnknownRFoption, bool, relax)
188
189 DECLARE3(void, sorting, double*, data, int, len, usr_bool, NAlast)
190 DECLARE3(void, sortingInt, int*, data, int, len, usr_bool, NAlast)
191 DECLARE4(void, ordering, double*, data, int, len, int, dim, int *, pos)
192 DECLARE4(void, orderingInt, int*, data, int, len, int, dim, int *, pos)
193
194
195
196 /*
197
198 See in R package RandomFields, /src/userinterfaces.cc
199 CALL#(...)
200 at the beginning for how to make the functions available
201 in a calling package
202
203 */
204 #ifdef __cplusplus
205 }
206 #endif
207
208
209 #endif
210
211
0
1 #ifndef miraculix_initrinsics_H
2 #define miraculix_initrinsics_H 1
3
4 #include <inttypes.h> // uintptr_t
5
6 // PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -mavx ODER -march=native
7 #ifdef __MMX__
8 #define MMX __MMX__
9 #endif
10 #ifdef __SSE__
11 #define SSE __SSE__
12 #endif
13 #ifdef __SSE2__
14 #define SSE2 __SSE2__
15 #endif
16 #ifdef __SSE3__
17 #define SSE3 __SSE3__
18 #endif
19 #ifdef __SSSE3__
20 #define SSSE3 __SSSE3__
21 #endif
22 #ifdef __SSE4A__
23 #define SSE4A __SSE4A__
24 #endif
25 #if defined __SSE41__ || defined __SS42__
26 #define SSE412 1
27 #endif
28 //
29 #ifdef __AVX__
30 #define AVX 1
31 #endif
32 #ifdef __AVX2__
33 #define AVX2 1
34 #endif
35
36
37 #if defined (AVX512)
38 #define SSEBITS 512
39 #define SSEMODE 30
40 #elif defined (SSE)
41 #define SSEBITS 256
42 #define SSEMODE 20
43 #elif defined (SSE)
44 #define SSEBITS 128
45 #define SSEMODE 10
46 #else
47 #define SSEBITS 64
48 #define SSEMODE 0
49 #endif
50
51 #ifndef WIN32
52 // #define FMA_AVAILABLE __FMA__
53 #endif
54
55
56 #if __GNUC__ > 4 || \
57 (__GNUC__ == 4 && (__GNUC_MINOR__ > 9 || \
58 (__GNUC_MINOR__ == 9 && __GNUC_PATCHLEVEL__ >= 1)))
59 //#define OpenMP4 1
60 #endif
61
62
63 //#define ALIGNED __declspec(align(SSEBITS/8))
64
65
66 #ifdef MMX
67 //#include <mmintrin.h>
68 #endif
69
70 #ifdef SSE
71 #include <xmmintrin.h>
72 #endif
73
74 #ifdef SSE2
75 //#include <emmintrin.h>
76 #endif
77
78 #ifdef SSE3
79 //#include <pmmintrin.h>
80 #endif
81
82 #ifdef SSSE3
83 //#include <tmmintrin.h>
84 #endif
85
86 #ifdef SSE4A
87 //#include <ammintrin.h>
88 #endif
89
90 #ifdef SSE412
91 //#include <smmintrin.h>
92 #endif
93
94 #if defined AVX || defined AVX2
95 #include <x86intrin.h>
96 #endif
97
98 #ifdef AVX512
99 //#include <immintrin.h>
100 #endif
101
102
103
104
105 #if defined AVX
106 #define BytesPerBlock 32
107 #define UBlockType __m256i
108 #define BlockType __m256i ALIGNED
109 #define Double __m256d
110 #define MAXDOUBLE _mm256_max_pd
111 #define MAXINTEGER _mm256_max_epi32
112 #define LOAD _mm256_load_si256
113 // #define EXPDOUBLE mm256_exp_pd // only on intel compiler
114 #define ADDDOUBLE _mm256_add_pd
115 #define SUBDOUBLE _mm256_sub_pd
116 #define MULTDOUBLE _mm256_mul_pd
117 #define LOADuDOUBLE _mm256_loadu_pd
118 #define LOADDOUBLE _mm256_load_pd
119 #define STOREuDOUBLE _mm256_storeu_pd
120 #define ZERODOUBLE _mm256_setzero_pd()
121
122 #elif defined SSE2
123 #define BytesPerBlock 16
124 #define UBlockType __m128i
125 #define BlockType __m128i ALIGNED
126 #define Double __m128d
127 #define MAXDOUBLE _mm_max_pd
128 #define MAXINTEGER _mm_max_epi32
129 #define LOAD _mm_load_si128
130 // #define EXPDOUBLE _mm_exp_pd // only on intel compiler
131 #define ADDDOUBLE _mm_add_pd
132 #define SUBDOUBLE _mm_sub_pd
133 #define MULTDOUBLE _mm_mul_pd
134 #define LOADuDOUBLE _mm_loadu_pd
135 #define LOADDOUBLE _mm_load_pd
136 #define STOREuDOUBLE _mm_storeu_pd
137 #define ZERODOUBLE _mm_setzero_pd()
138
139 #else
140 #define BytesPerBlock 8
141 #endif
142
143 #define algn_general(X) ((1L + (uintptr_t) (((uintptr_t) X - 1L) / BytesPerBlock)) * BytesPerBlock)
144 double inline *algn(double *X) {assert(algn_general(X)>=(uintptr_t)X); return (double *) algn_general(X); }
145 int inline *algnInt(int *X) {assert(algn_general(X)>=(uintptr_t)X); return (int *) algn_general(X); }
146 #define ALIGNED __attribute__ ((aligned (BytesPerBlock)))
147 #define doubles (BytesPerBlock / 8)
148 #define integers (BytesPerBlock / 8)
149
150 #endif
151
152
55 Martin Schlather, schlather@math.uni-mannheim.de
66
77
8 Copyright (C) 2015 Martin Schlather
8 Copyright (C) 2015 -- 2017 Martin Schlather
99
1010 This program is free software; you can redistribute it and/or
1111 modify it under the terms of the GNU General Public License
2727 #ifndef kleinkram_rfutils_h
2828 #define kleinkram_rfutils_h 1
2929
30 #include "Basic_utils.h"
31
30 #include <R.h>
31 #include <Rinternals.h>
32 #include "Basic_utils.h" //#include "local1.h"
3233
3334 typedef char name_type[][MAXCHAR];
3435
3536 void strcopyN(char *dest, const char *src, int n);
3637
3738 usr_bool UsrBool(SEXP p, char *name, int idx);
39 usr_bool UsrBoolRelaxed(SEXP p, char *name, int idx);
3840
3941 #define INT Integer(el, name, 0)
40 #define LOG Logical(el, name, 0)
42 #define LOGI Logical(el, name, 0)
4143 #define NUM Real(el, name, 0)
4244 #define USRLOG UsrBool(el, name, 0)
45 #define USRLOGRELAXED UsrBoolRelaxed(el, name, 0)
4346 #define CHR Char(el, name)
4447 #define STR(X, N) strcopyN(X, CHAR(STRING_ELT(el, 0)), N);
4548 #define POS0INT NonNegInteger(el, name) /* better: non-negative */
5760 SEXP Mat(double* V, int row, int col, int max);
5861 SEXP Mat_t(double* V, int row, int col, int max);
5962 SEXP MatInt(int* V, int row, int col, int max) ;
63 SEXP MatString(char **V, int row, int col, int max);
6064 SEXP Array3D(int** V, int depth, int row, int col, int max) ;
6165 SEXP String(char *V);
6266
6771 SEXP Mat(double* V, int row, int col);
6872 SEXP Mat_t(double* V, int row, int col);
6973 SEXP MatInt(int* V, int row, int col) ;
74 SEXP MatString(char** V, int row, int col);
7075 SEXP Array3D(int** V, int depth, int row, int col) ;
7176 SEXP String(char V[][MAXCHAR], int n, int max);
7277 SEXP String(int *V, const char * List[], int n, int endvalue);
102107
103108
104109 SEXP ExtendedInteger(double x);
105 SEXP ExtendedBoolean(double x);
106110 SEXP ExtendedBooleanUsr(usr_bool x);
107111
108112
111115 void XCXt(double *X, double *C, double *V, int nrow, int dim);
112116 void AtA(double *a, int nrow, int ncol, double *A);
113117 void xA(double *x, double*A, int nrow, int ncol, double *y);
118 void xA_noomp(double *x, double*A, int nrow, int ncol, double *y);
114119 void xA(double *x1, double *x2, double*A, int nrow, int ncol, double *y1,
115120 double *y2);
121 void xAx(double *x, double*A, int nrow, double *y);
116122 void Ax(double *A, double*x, int nrow, int ncol, double *y);
117123 void Ax(double *A, double*x1, double*x2, int nrow, int ncol, double *y1,
118124 double *y2);
124130 void matmulttransposed(double *A, double *B, double *C, int m, int l, int n);
125131 void matmult_2ndtransp(double *A, double *B, double *C, int m, int l, int n);
126132 void matmult_tt(double *A, double *B, double *C, int m, int l, int n);
127 double * matrixmult(double *m1, double *m2, int dim1, int dim2, int dim3);
133 double *matrixmult(double *m1, double *m2, int dim1, int dim2, int dim3);
128134
129135
130136
156162 }
157163
158164 double scalar(double *A, double *B, int N);
165 double ownround(double x);
159166
167 #define Mod(ZZ, modulus) ((ZZ) - FLOOR((ZZ) / (modulus)) * (modulus))
168 double lonmod(double x, double modulus);
160169
161170 /*
162171 extern "C" void vectordist(double *v, int *dim, double *dist, int *diag);
163172 bool is_diag(double *aniso, int dim);
164 */
173 */
165174
166175 #endif
0
1 #ifndef LINEAR_RU_H
2 #define LINEAR_RU_H 1
3
4
5 #define LINEAR_AVX 6
6 #define LINEAR_BASE 1
7 #define LINEAR_AVX_PARALLEL 9
8 #define LINEAR_BASE_PARALLEL 10
9
10 void linearX(double *x, double y, int len, double *out, int n);
11
12
13 #endif
0 #include "/home/schlather/R/x86_64-pc-linux-gnu-library/3.5/RandomFieldsUtils/include/Basic_utils.h"
0 #include "/home/schlather/R/x86_64-pc-linux-gnu-library/3.5/RandomFieldsUtils/include/General_utils.h"
0 #include "/home/schlather/R/x86_64-pc-linux-gnu-library/3.5/RandomFieldsUtils/include/zzz_RandomFieldsUtils.h"
0
1 #ifndef SCALAR_RU_H
2 #define SCALAR_RU_H 1
3
4
5 #define SCALAR_AVX 6
6 #define SCALAR_KAHAN 8
7 #define SCALAR_BASE 1
8 #define SCALAR_AVX_PARALLEL 9
9 #define SCALAR_BASE_PARALLEL 10
10
11 // double scalarX(double *x, double *y, int len, int n);
12
13
14 #endif
55 Martin Schlather, schlather@math.uni-mannheim.de
66
77
8 Copyright (C) 2015 Martin Schlather
8 Copyright (C) 2015 -- 2017 Martin Schlather
99
1010 This program is free software; you can redistribute it and/or
1111 modify it under the terms of the GNU General Public License
0
1
2
3 /*
4 Authors
5 Martin Schlather, schlather@math.uni-mannheim.de
6
7
8 Copyright (C) 2015 -- 2017 Martin Schlather
9
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 3
13 of the License, or (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 */
24
25 #ifndef rfutils_init_H
26 #define rfutils_init_H 1
27
28 #include "Options_utils.h"
29 #include "errors_messages.h"
30 #include "scalar.h"
31 #include "Utils.h"
32
33
34 #ifdef HAVE_VISIBILITY_ATTRIBUTE
35 # define attribute_hidden __attribute__ ((visibility ("hidden")))
36 #else
37 # define attribute_hidden
38 #endif
39
40 #ifdef __cplusplus
41 extern "C" {
42 #endif
43
44 #define MY_PACKAGE "RandomFieldsUtils"
45 #define MY_ACRONYM XX
46 #include "zzz_calls.h"
47
48 DECLARE1(void, solve_DELETE, solve_storage**, S)
49 DECLARE1(void, solve_NULL, solve_storage*, x)
50 DECLARE7(int, solvePosDef, double*, M, int, size, bool, posdef,
51 double *, rhs, int, rhs_cols, double *, logdet, solve_storage *, PT)
52 DECLARE8(int, solvePosDefResult, double*, M, int, size, bool, posdef,
53 double *, rhs, int, rhs_cols, double *, result, double*, logdet,
54 solve_storage*, PT)
55 DECLARE4(int, sqrtPosDefFree, double *, M, int, size, solve_storage *, pt,
56 solve_param *, sp)
57 DECLARE3(int, sqrtRHS, solve_storage *, pt, double*, RHS, double *, res)
58 DECLARE2(int, invertMatrix, double *, M, int, size)
59 DECLARE2(double, StruveH, double, x, double, nu)
60 DECLARE3(double, StruveL, double, x, double, nu, bool, expScale1d)
61 DECLARE1(double, I0mL0, double, x)
62 DECLARE3(double, WM, double, x, double, nu, double, factor)
63 DECLARE3(double, DWM, double, x, double, nu, double, factor)
64 DECLARE3(double, DDWM, double, x, double, nu, double, factor)
65 DECLARE3(double, D3WM, double, x, double, nu, double, factor)
66 DECLARE3(double, D4WM, double, x, double, nu, double, factor)
67 DECLARE4(double, logWM, double, x, double, nu1, double, nu2, double, factor)
68 DECLARE1(double, Gauss, double, x)
69 DECLARE1(double, DGauss, double, x)
70 DECLARE1(double, DDGauss, double, x)
71 DECLARE1(double, D3Gauss, double, x)
72 DECLARE1(double, D4Gauss, double, x)
73 DECLARE1(double, logGauss, double, x)
74
75 DECLARE1(void, getErrorString, errorstring_type, errorstring)
76 DECLARE1(void, setErrorLoc, errorloc_type, errorloc)
77 DECLARE1(void, getUtilsParam, utilsparam **, up)
78 DECLARE10(void, attachRFoptions, const char **, prefixlist, int, N,
79 const char ***, all, int *, allN, setparameterfct, set,
80 finalsetparameterfct, final, getparameterfct, get,
81 deleteparameterfct, del,
82 int, PLoffset,
83 bool, basicopt)
84 DECLARE2(void, detachRFoptions, const char **, prefixlist, int, N)
85 DECLARE1(void, relaxUnknownRFoption, bool, relax)
86
87 DECLARE3(void, sorting, double*, data, int, len, usr_bool, NAlast)
88 DECLARE3(void, sortingInt, int*, data, int, len, usr_bool, NAlast)
89 DECLARE4(void, ordering, double*, data, int, len, int, dim, int *, pos)
90 DECLARE4(void, orderingInt, int*, data, int, len, int, dim, int *, pos)
91 DECLARE4(double, scalarX, double *, x, double *, y, int, len, int, n)
92 DECLARE2(double, detPosDef, double *, M, int, size)
93 DECLARE8(int, XCinvXdet,double, *M, int, size, double *,X, int, X_cols,
94 double *, XCinvX, double *, det, bool, log, solve_storage, *PT)
95 DECLARE10(int, XCinvYdet,double, *M, int, size, bool, posdef,
96 double *, X, double *, Y, int, cols,
97 double *, XCinvY, double *, det, bool, log, solve_storage, *PT)
98 // DECLARE5(double, XCinvXlogdet, double *, M, int, size, double *, X,
99 // int, X_cols, solve_storage *, PT)
100 DECLARE2(bool, is_positive_definite, double *, C, int, dim)
101 DECLARE2(void, chol2inv, double *, MPT, int, size)
102 DECLARE2(int, chol, double *, MPT, int, size)
103 // DECLARE2(double *, ToRealI, SEXP, X, bool *, create)
104 DECLARE3(int *, ToIntI, SEXP, X, bool *, create, bool, round)
105 DECLARE1(void, pid, int *, i)
106 DECLARE1(void, sleepMicro, int *, i)
107
108 /*
109
110 See in R package RandomFields, /src/userinterfaces.cc
111 CALL#(...)
112 at the beginning for how to make the functions available
113 in a calling package
114
115 */
116 #ifdef __cplusplus
117 }
118 #endif
119
120
121 #endif
122
123
0
1
2
3 /*
4 Authors
5 Martin Schlather, schlather@math.uni-mannheim.de
6
7
8 Copyright (C) 2015 -- 2017 Martin Schlather
9
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 3
13 of the License, or (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 */
24
25 #ifndef rfutils_calls_H
26 #define rfutils_calls_H 1
27 #include <R_ext/Rdynload.h>
28
29
30 #define CALL0(V, N) \
31 attribute_hidden V RU_##N() { \
32 static V(*fun)(AV) = NULL; \
33 if (fun == NULL) fun = (V (*) ()) R_GetCCallable(MY_PACKAGE, #N); \
34 return fun(); }
35 #define DECLARE0(V, N) \
36 typedef V (*N##_type)(); \
37 /* extern N##_type Ext_##N; */ \
38 attribute_hidden V RU_##N(); \
39 V N();
40
41 #define CALL1(V, N, AV, AN) \
42 /* N##_type Ext_##N = NULL; */ \
43 attribute_hidden V RU_##N(AV AN) { \
44 static N##_type fun = NULL; \
45 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
46 return fun(AN); }
47 #define DECLARE1(V, N, AV, AN) \
48 typedef V (*N##_type)(AV AN); \
49 /* extern N##_type Ext_##N; */ \
50 attribute_hidden V RU_##N(AV AN); \
51 V N(AV AN);
52
53 #define CALL2(V, N, AV, AN, BV, BN) \
54 /* N##_type Ext_##N = NULL; */ \
55 attribute_hidden V RU_##N(AV AN, BV BN) { \
56 static N##_type fun = NULL; \
57 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
58 return fun(AN, BN); }
59 #define DECLARE2(V, N, AV, AN, BV, BN) \
60 typedef V (*N##_type)(AV AN, BV BN); \
61 /* extern N##_type Ext_##N; */ \
62 attribute_hidden V RU_##N(AV AN, BV BN); \
63 V N(AV AN, BV BN);
64
65 #define CALL3(V, N, AV, AN, BV, BN, CV, CN) \
66 /* N##_type Ext_##N = NULL; */ \
67 attribute_hidden V RU_##N(AV AN, BV BN, CV CN) { \
68 static N##_type fun = NULL; \
69 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
70 return fun(AN, BN, CN); }
71 #define DECLARE3(V, N, AV, AN, BV, BN, CV, CN) \
72 typedef V (*N##_type)(AV AN, BV BN, CV CN); \
73 /* extern N##_type Ext_##N; */ \
74 attribute_hidden V RU_##N(AV AN, BV BN, CV CN); \
75 V N(AV AN, BV BN, CV CN);
76
77 #define CALL4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
78 /* N##_type Ext_##N = NULL; */ \
79 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN) { \
80 static N##_type fun = NULL; \
81 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
82 return fun(AN, BN, CN, DN); }
83 #define DECLARE4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
84 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN); \
85 /* extern N##_type Ext_##N; */ \
86 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN); \
87 V N(AV AN, BV BN, CV CN, DV DN);
88
89 #define CALL5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
90 /* N##_type Ext_##N = NULL; */ \
91 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN) { \
92 static N##_type fun = NULL; \
93 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
94 return fun(AN, BN, CN, DN, EN); }
95 #define DECLARE5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
96 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN); \
97 /* extern N##_type Ext_##N; */ \
98 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN); \
99 V N(AV AN, BV BN, CV CN, DV DN, EV EN);
100
101 #define CALL6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
102 /* N##_type Ext_##N = NULL; */ \
103 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN) { \
104 static N##_type fun = NULL; \
105 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
106 return fun(AN, BN, CN, DN, EN, FN); }
107 #define DECLARE6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
108 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
109 /* extern N##_type Ext_##N; */ \
110 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
111 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN);
112
113 #define CALL7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
114 /* N##_type Ext_##N = NULL; */ \
115 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN) { \
116 static N##_type fun = NULL; \
117 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
118 return fun(AN, BN, CN, DN, EN, FN, GN); }
119 #define DECLARE7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
120 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
121 /* extern N##_type Ext_##N; */ \
122 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
123 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN);
124
125 #define CALL8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
126 /* N##_type Ext_##N = NULL; */ \
127 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN) { \
128 static N##_type fun = NULL; \
129 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
130 return fun(AN, BN, CN, DN, EN, FN, GN, HN); }
131 #define DECLARE8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
132 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
133 /* extern N##_type Ext_##N; */ \
134 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
135 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN);
136
137 #define CALL9(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN) \
138 /* N##_type Ext_##N = NULL; */ \
139 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN) { \
140 static N##_type fun = NULL; \
141 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
142 return fun(AN, BN, CN, DN, EN, FN, GN, HN, IN); }
143 #define DECLARE9(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN) \
144 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN); \
145 /* extern N##_type Ext_##N; */ \
146 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN); \
147 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN);
148
149
150 #define CALL10(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN, JV, JN) \
151 /* N##_type Ext_##N = NULL; */ \
152 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN) { \
153 static N##_type fun = NULL; \
154 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
155 return fun(AN, BN, CN, DN, EN, FN, GN, HN, IN, JN); }
156 #define DECLARE10(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN, JV, JN) \
157 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN); \
158 /* extern N##_type Ext_##N; */ \
159 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN); \
160 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN);
161
162
163 #endif
1515 prints the names and the values; for vectors \command{cat}
1616 is used and for lists \command{str}
1717 }
18 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
19 \url{http://ms.math.uni-mannheim.de/de/publications/software}}
18 \me
2019
2120 \keyword{print}
2221
00 \name{RFoptions}
11 \alias{RFoptions}
2 \alias{PIVOT_UNDEFINED}
3 \alias{PIVOT_NONE}
4 \alias{PIVOT_AUTO}
5 \alias{PIVOT_DO}
6 \alias{PIVOT_IDX}
7 %\alias{PIVOT_IDXBACK}
8 \alias{PIVOTSPARSE_MMD}
9 \alias{PIVOTSPARSE_RCM}
210 \title{Setting control arguments}
311 \description{
412 \command{\link{RFoptions}} sets and returns control arguments for the analysis
2028 The subsections below comment on\cr
2129 \bold{1. \code{basic}: Basic options}\cr
2230 \bold{2. \code{solve}: Options for solving linear systems}\cr
31 \bold{3. Reserved words}\cr
32 \cr
2333
2434 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2535 % \bold{16. Options for RFloglikelihood}\cr
3040 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3141 \bold{1. Basic options}
3242 \describe{
33 \item{asList}{logical. Lists of arguments are treated slightly
43 \item{\code{asList}}{logical. Lists of arguments are treated slightly
3444 different from non-lists. If \code{asList=FALSE} they are treated the
3545 same way as non-lists. This options being set to \code{FALSE} after
3646 calling \command{RFoptions} it should be set as first element of a list.
6979 Default: 1 \cr % [also do].\cr
7080 }
7181
82 \item{\code{helpinfo}}{logical. If \code{TRUE} then
83 additional information is printed for more efficient programming
84 in R.
85 }
86
87 \item{\code{kahanCorrection}}{
88 logical. If \code{TRUE}, the Kahan summation algorithm is used for
89 calculating scalar products.
90
91 Default: false
92 }
93
7294 \item{\code{printlevel}}{If \code{printlevel}\eqn{\le0}{<=0}
7395 there is not any output on the screen. The
7496 higher the number the more tracing information is given.
87109 Default: 1 %[also do].\cr
88110 }
89111
90 \item{seed}{integer (currently only used by the package RandomFields).
112 \item{\code{seed}}{integer (currently only used by the package
113 RandomFields).
91114 If \code{NULL} or \code{NA}
92115 \command{\link[base]{set.seed}} is \bold{not} called.
93116 Otherwise, \code{\link[base]{set.seed}(seed)} is set
135158
136159
137160 \describe{ % to do
161 \item{\code{det_as_log}}{
162 }
163 \item{\code{eigen2zero}}{
164 When the svd or eigen decomposition is calculated,
165 all values with modulus less than or equal to \code{eigen2zero}
166 are set to zero.
167
168 Default: \code{1e-12}
169 }
138170 \item{\code{max_chol}}{integer. Maximum number of rows of a matrix in
139171 a Cholesky decomposition
140172
141 Default: \eqn{8192}
142 }
143 \item{\code{max_svn}}{integer. Maximum number of rows of a matrix in
173 Default: \eqn{16384}
174 }
175 \item{\code{max_svd}}{integer. Maximum number of rows of a matrix in
144176 a svd decomposition
145177
146 Default: \eqn{6555}
147 }
148
149 \item{\code{solve_method}}{
178 Default: \eqn{10000}
179 }
180
181 \item{\code{pivot}}{Type of pivoting for the Cholesky
182 decomposition. Possible values are
183 \describe{
184 \item{PIVOT_NONE}{No pivoting.}
185 \item{PIVOT_AUTO}{If the matrix has a size greater than
186 3x3 and Choleskey fails without pivoting, privoting
187 is done. For matrices of size less than 4x4, no pivoting and
188 no checks are performed. See also \code{PIVOT_DO}}
189 \item{PIVOT_DO}{Do always pivoting.
190 NOTE: privoted Cholesky decomposition yields only very approximately
191 an upper triangular matrix L, but still L^t L = M holds true.
192 % The information about the pivoting sequence are attributed to
193 % the result.
194 }
195 \item{PIVOT_IDX}{uses the same pivoting as in the previous
196 pivoted decomposition. This option becomes relevant only when
197 simulations with different parameters or different models shall be
198 performed with the same seed so that also the pivoting must be
199 coupled.
200 % The information about the pivoting sequence are attributed to
201 % the result.
202 }
203 % \item{PIVOT_IDXBACK}{ same as \code{PIVOT_IDX}, but
204 % the sequence of indices of the pivoting is returned via
205 % \code{RFoptions()$solve$pivot_idx}.}
206 }
207
208 Default: \code{PIVOT_NONE}
209 }
210
211 \item{\code{pivot_actual_size}}{integer.
212 Genuine dimension of the linear mapping given by a matrix in \link{cholx}.
213 This is a very rarely used option when pivoting with
214 \code{pivot=PIVOT_IDX}.
215 }
216
217 \item{\code{pivot_check}}{logical. Only used in pivoted Cholesky
218 decomposition.
219 If \code{TRUE} and a numerically zero diagonal element is detected,
220 it is checked whether the offdiagonal elements are numerically zero
221 as well.
222 (See also \code{pivot_max_deviation} and
223 \code{pivot_max_reldeviation}.)
224 If \code{NA} then only a warning is given.
225
226 Default: \code{TRUE}
227 }
228
229 \item{\code{pivot_idx}}{vector of integer.
230 Sequence of pivoting indices in pivoted Cholesky decomposition.
231 Note that
232 \code{pivot_idx[1]} gives the number of indices that will be
233 used. The vector must have at least the length
234 \code{pivot_idx[1] + 1}.
235
236 Default: \code{NULL}
237 }
238
239 \item{\code{pivot_relerror}}{positive number.
240 Tolerance for (numerically) negative eigenvalues and for (numerically)
241 overdetermined systems appearing in the pivoted Cholesky decomposition.
242
243 Default: \code{1e-11}
244 }
245
246 \item{\code{pivot_max_deviation}}{positive number.
247 Together with \code{pivot_max_reldeviation} it determines
248 when the rest of the matrix (eigenvalues) in the pivoted
249 Cholesky decomposition are considered as zero.
250
251 Default: \code{1e-10}
252 }
253
254 \item{\code{pivot_max_reldeviation}}{positive number.
255 Together with \code{pivot_max_deviation} it determines
256 when the rest of the matrix (eigenvalues) in the pivoted
257 Cholesky decomposition are considered as zero.
258
259 Default: \code{1e-10}
260 }
261
262
263 \item{\code{solve_method}}{
150264 vector of at most 3 integers that gives the sequence of methods
151265 in order to inverse a matrix or to calculate its square root:
152266 \code{"cholesky"}, \code{"svd"}, \code{"eigen"} \code{"sparse"},
166280 }
167281
168282 \item{\code{spam_min_n}}{
169 integer. Has the matrix
283 integer. THe minimal size for a matrix to apply a
284 sparse matrix algorithms automatically.
170285
171286 Default: 400
172287 }
178293 }
179294 \item{\code{spam_pivot}}{
180295 integer. Pivoting algorithm for sparse matrices:
181 0:none; 1:MMD, 2:RCM
182
296 \describe{
297 \item{PIVOT_NONE}{No pivoting}
298 \item{PIVOTSPARSE_MMD}{}
299 \item{PIVOTSPARSE_RCM}{}
300 }
183301 See package \code{spam} for details.
184302
185 Default: 1
303 Default: PIVOTSPARSE_MMD
186304 }
187305 \item{\code{spam_sample_n}}{
188306 Whether a matrix is sparse or not is tested by a
206324
207325 Default: \code{0}
208326 }
209 \item{\code{eigen2zero}}{
210 When the svd or eigen decomposition is calculated,
211 all values with modulus less than or equal to \code{eigen2zero}
212 are set to zero.
213
214 Default: \code{1e-12}
215 }
216 \item{\code{use_spam}}{
327 \item{\code{use_spam}}{
217328 Should the package \code{spam} (sparse matrices)
218329 be used for matrix calculations?
219330 If \code{TRUE} \pkg{spam} is always used. If \code{FALSE},
223334 Default: \code{NA}.
224335 }
225336 }
337
338 \bold{3. Reserved Words}
339 \describe{
340 \item{\code{LIST}}{
341 \code{LIST} usually equals the output of \code{RFoptions()}.
342 This argument is used to reset the RFoptions.
343 Some of the options behave differently if passed through
344 \code{LIST}. E.g. a warning counter is not reset.
345 The argument \code{LIST} cannot be combined with any other arguments.
346 }
347 \item{\code{GETOPTIONS}}{string vector of prefixes that indicate
348 classes of options. In this package they
349 can be \code{"basic"} and \code{"solve"}. (E.g. package
350 \pkg{RandomFields} has many more classes of options.)
351 The given classes of options are then
352 returned by \code{RFoptions()}. Note that the values are the
353 previous values.
354
355 \code{GETOPTIONS} must always be the very first argument.
356 }
357 \item{\code{SAVEOPTIONS}}{string vector of prefixes. Same as for
358 \code{GETOPTIONS}, except that important classes are always
359 returned and thus should not be given. Hence \code{SAVEOPTIONS}
360 is often a convenient short cut for \code{GETOPTIONS}.
361 The class always included in this package is \code{"basic"}, in
362 package \pkg{RandomFields} these are the two classes
363 \code{"basic"} and \code{"general"}.
364
365 \code{SAVEOPTIONS} must always be the very first argument. In
366 particular, it may not given at the same time with \code{GETOPTIONS}.
367 }
368 }
226369 }
227370
228371
232375 arguments, otherwise.
233376 }
234377
235 %\references{}
236 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
237 \url{http://ms.math.uni-mannheim.de/de/publications/software}}
238
378 \me
239379
240380 \examples{
241381
6767 }
6868
6969 }
70 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
71 }
70 \me
71
7272 \keyword{math}
22 \alias{chol}
33 \alias{cholx}
44 \alias{cholPosDef}
5 \alias{chol2mv}
6 \alias{tcholRHS}
57 \title{Cholesky Decomposition of Positive Definite Matrices}
68 \description{
7 This function calculates the Choleskey decomposition of a matrix.
9 This function calculates the Cholesky decomposition of a matrix.
810 }
911
1012 \usage{
1113 cholx(a)
14 chol2mv(C, n)
15 tcholRHS(C, RHS)
1216 %, sparse=NA, method=-1)
1317 }
1418 \arguments{
1519 \item{a}{a square real-valued positive definite matrix
1620 }
21 \item{C}{a (pivoted) Cholesky decomposition calculated by \command{cholx}}
22 \item{n}{integer. Number of realisations of the multivariate normal
23 distribution}
24 \item{RHS}{vector}
1725
1826 % \item{sparse}{logical or \code{NA}.
1927 % If \code{NA} the function determines whether a sparse
2533 % }
2634 }
2735 \value{
28 a matrix containing the Choleskey decomposition (in its upper part)
36 \command{cholx}
37 returns a matrix containing the Cholesky decomposition (in its upper
38 part).
39
40 \command{chol2mv} takes the Cholesky decomposition and returns
41 a \code{n} realisations of a multivariate normal distribution
42 with mean 0 and covariance function \code{a}
43
44 \command{tcholRHS} multiplies the vector \code{RHS} from the right to
45 \emph{lower} triangular matrix of the Cholesky decomposition.
46 See examples below.
47
2948 }
3049 \details{
3150 If the matrix is diagonal direct calculations are performed.
3958 % \references{ See \link[spam]{chol.spam} of the package \pkg{spam} }
4059
4160 \seealso{
61 % \link{chol2mv}, \link{tcholRHS}
4262 \link[spam]{chol.spam} in the package \pkg{spam}
4363 }
44 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
45 }
64 \me
4665 \keyword{math}
4766 \examples{
4867
6685 stopifnot(all(abs(C2 - C1) < 10^{-9}))
6786 }
6887
88
89
90 ##########################
91 ## Example showing the use of chol2mv and tcholRHS
92 n <- 10
93 M <- matrix(nc=n, runif(n^2))
94 M <- M \%*\% t(M) + diag(n)
95 C <- cholx(M)
96 set.seed(0)
97 v1 <- chol2mv(C, 1)
98 set.seed(0)
99 v2 <- tcholRHS(C, rnorm(n))
100 stopifnot(all(v1 == v2))
101
102
103
104 ##########################
105 ## The following example shows pivoted Cholesky can be used
106 ## and the pivotation permutation can be transferred to
107 ## subsequent Cholesky decompositions
108 % library(RandomFieldsUtils)
109 set.seed(0)
110 n <- if (interactive()) 1000 else 100
111 x <- 1:n
112 y <- runif(n)
113 M <- x \%*\% t(x) + rev(x) \%*\% t(rev(x)) + y \%*\% t(y)
114
115 ## do pivoting
116 RFoptions(pivot = PIVOT_DO)
117 print(system.time(C <- cholx(M)))
118 print(range(crossprod(C) - M))
119 str(C)
120
121 ## use the same pivoted decomposition as in the previous decomposition
122 M2 <- M + n * diag(1:n)
123 RFoptions(pivot = PIVOT_IDX,
124 pivot_idx = attr(C, "pivot_idx"),
125 pivot_actual_size = attr(C, "pivot_actual_size"))
126 print(system.time(C2 <- cholx(M2)))
127 print(range(crossprod(C2) - M2))
128 range((crossprod(C2) - M2) / M2)
129 str(C2)
130
131 \dontshow{RFoptions(pivot_idx = integer(0))}
132
69133 }
70134
0 \name{confirm}
1 \alias{confirm}
2
3 \title{Test if Two Objects are (Nearly) Equal}
4 \description{
5 \code{confirm(x, y)} is a utility to compare R objects \code{x} and \code{y}
6 testing \sQuote{near equality} base on
7 \command{\link[base]{all.equal}}. It is written too allow
8 different behaviour on different operating systems
9 }
10 \usage{
11 confirm(x, y, ...)
12 }
13
14 \arguments{
15 \item{x,y,...}{see \command{\link[base]{all.equal}}}
16 }
17
18 \value{
19 Only \code{TRUE} or error in linux-gnu.
20 Otherwise logical.
21 }
22
23 \me
24
25
26
27 \examples{
28 x <- 3
29 confirm(gauss(x), exp(-x^2))
30 }
31
32 \keyword{sysdata}
33 \keyword{utilities}
34
35
36
37
38
39
40
41
42
43
44 % LocalWords: pid unix Schlather url
0 \name{dbinorm}
1 \alias{dbinorm}
2 \title{Density of a bivariate normal distribution}
3 \description{
4 The function calculates the value of a bivariate normal distribution
5 with mean 0.
6 }
7 \usage{
8 dbinorm (x, S)
9 }
10 \arguments{
11 \item{x}{
12 a matrix containing the \eqn{x} values and the \eqn{y} values
13 in the first and second row respectively. Or it is a list of two
14 vectors.
15 }
16 \item{S}{the covariance matrix}
17 }
18 \value{
19 a vector according to the size of \code{x}
20 }
21 \me
22
23
24 %\examples{}
25
26 \keyword{utilities}
27 \keyword{misc}
4242 \code{file}.lock has been created}
4343 }
4444
45 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
46 }
45 \me
4746
4847 \examples{
4948 \dontrun{
3131 Stein, M. L. (1999) \emph{Interpolation of Spatial Data.} New York: Springer-Verlag
3232 }
3333
34 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
35 }
34 \me
3635 \seealso{
3736 For more details see \command{\link[RandomFields]{RMgauss}}.
3837 }
4443
4544 \examples{
4645 x <- 3
47 stopifnot(gauss(x) == exp(-x^2))
46 confirm(gauss(x), exp(-x^2))
4847 }
2424
2525 }
2626
27 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
28 }
27 \me
2928
3029
3130 \examples{
3736 \keyword{sysdata}
3837 \keyword{utilities}
3938
40
41
42
43
44
45
46
47
48
4939 % LocalWords: pid unix Schlather url
0 \newcommand{\martin}{Martin Schlather, \email{schlather@math.uni-mannheim.de}, \url{http://ms.math.uni-mannheim.de}}
1 \newcommand{\marco}{Marco Oesting, \email{oesting@mathematik.uni-siegen.de}, \url{https://www.uni-siegen.de/fb6/src/scheffler/mitarbeiter/oesting}}
2 \newcommand{\me}{\author{\martin}}
3 \newcommand{\RFU}{See \link[RandomFieldsUtils]{RFoptions}}
4
5
6
7 % library(RandomFieldsUtils); ?RFoptions
(New empty file)
8282
8383 }
8484
85 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
86 }
85 \me
8786
8887 \seealso{
8988 \command{\link{nonstwm}}
9796 \keyword{math}
9897
9998
100 \examples{
101 confirm <- function(x, y) stopifnot(all.equal(x, y))
102
99 \examples{% library(RandomFieldsUtils)
103100 x <- 3
104101 confirm(matern(x, 0.5), exp(-x))
105102 confirm(matern(x, Inf), gauss(x/sqrt(2)))
5151 }
5252 }
5353
54 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
55 }
54 \me
5655
5756 \seealso{
5857 \command{\link{matern}}.
4949 system.time(z<-orderx(x, from=1, to=k)) ## much faster
5050 stopifnot(all(x[y ]== x[z])) ## same result
5151 }
52 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
53 }
52 \me
5453 \keyword{univar}
5554 \keyword{manip}
0 \name{rowMeansx}
1 \alias{rowMeans}
2 \alias{rowMeansx}
3 \alias{colMax}
4 \alias{rowProd}
5 \alias{SelfDivByRow}
6 \alias{quadratic}
7 \alias{dotXV}
8
9 \title{Some Further Row and Column Functions}
10 \description{
11 The function \command{rowMeansx} returns weighted row means;\cr
12 the function \command{colMax} returns column maxima;\cr
13 the function \command{rowProd} returns the product of each row;\cr
14 the function \command{quadratic} calculates a quadratic form\cr
15 the function \command{SelfDivByRow} devides each column by a scalar;\cr
16 the function \command{dotXV} calculates columnwise the dot product;\cr
17 }
18 \usage{
19 rowMeansx(x, weight=NULL)
20 colMax(x)
21 rowProd(x)
22 SelfDivByRow(x, v)
23 quadratic(x, v)
24 dotXV(x, w)
25 }
26
27 \arguments{
28 \item{x}{numerical (or logical) matrix}
29 \item{v}{vector whose length equals the number of columns of \code{x}}
30 \item{w}{vector whose length equals the number of rows of \code{x}}
31 \item{weight}{numerical or logical vector of length \code{nrow(x)}}
32 }
33
34 \details{
35 \code{quadratic(v,x)} calculates the quadratic form \eqn{v^\top x v};
36 The matrix \code{x} must be squared.
37 }
38
39 \value{
40 \command{rowMeansx} returns a vector of length\code{nrow(x)}.
41
42 \command{colMax} returns a vector of length \code{ncol(x)}.
43
44 \command{rowProd} returns a vector of length \code{nrow(x)}.
45
46 \command{quadratic} returns a scalar.
47
48 \command{SelfDivByRow} returns a matrix of same size as \code{x}.
49
50 \command{dotXV} returns a matrix of same size as \code{x}.
51
52 }
53
54 \me
55
56
57 \examples{
58
59 c <- if (interactive()) 10000 else 10
60 r <- if (interactive()) 20000 else 20
61 M <- matrix(nc = r, nr=r, 1:(c * r))
62
63 ## unweighted means, compare to rowMeans
64 print(system.time(m1 <- rowMeans(M)))
65 print(system.time(m2 <- rowMeansx(M)))
66 stopifnot(all.equal(m1, m2))
67
68 ## weighted row means, compare to rowMeans
69 W <- 1 / (ncol(M) : 1)
70 print(system.time({M0 <- t(W * t(M)); m1 <- rowMeans(M0)}))
71 print(system.time(m2 <- rowMeansx(M, W)))
72 stopifnot(all.equal(m1, m2))
73
74 print(system.time(m1 <- apply(M, 2, max)))
75 print(system.time(m2 <- colMax(M)))
76 stopifnot(m1 == m2)
77
78 }
79
80
81 \keyword{utilities}
82
83
84
85
86
87
88
89
90
91
92 % LocalWords: pid unix Schlather url
1515 \value{
1616 No value is returned.
1717 }
18 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
19 }
18 \me
2019
2120 \examples{
2221 ## next command waits half a second before returning
5656
5757 Else if the matrix is sparse the package \pkg{spam} is used.
5858
59 Else the Cholesky decomposition is tried.
59 Else the Cholesky decomposition is tried. Note that with
60 \code{RFoptions(pivot= )} pivoting can be enabled. Pivoting is about
61 30\% slower.
62
6063 If it fails, the eigen value decomposition is tried.
6164 }
6265
6669 \seealso{
6770 \link[spam]{chol.spam} in the package \pkg{spam}
6871 }
69 \author{Martin Schlather, \email{schlather@math.uni-mannheim.de}
70 }
72 \me
7173 \keyword{math}
7274 \examples{
73 if (FALSE) {
74 ## This examples shows that 'solvex' can be much faster than 'solve'
75 % library(RandomFieldsUtils)
7576
76 ## creating a covariance matrix for a temporal process
77 covmatrix <- function(model, x) {
78 x <- as.matrix(dist(x))
79 return(eval(substitute(model)))
80 }
77 RFoptions(solve_method = "cholesky", printlevel=1)
78 set.seed(1)
79 n <- 1000
80 x <- 1:n
81 y <- runif(n)
8182
82 size <- 600
83 x <- runif(size, 0, size / 10)
84 M <- covmatrix((1 - x) * (x < 1) , x) ## Askey's model of covariance
85 b <- seq(0, 1, len=size)
86 system.time(inv2 <- solve(M, b))
87 system.time(inv1 <- solvex(M, b)) ## much faster in this case
88 range(inv2 - inv1)
89 stopifnot(all(abs(inv2 - inv1) < 10^{-9}))
83
84 ## FIRST EXAMPLE: full rank matrix
85 M <- exp(-as.matrix(dist(x) / n))
86 b0 <- matrix(nr=n, runif(n * 5))
87 b <- M \%*\% b0 + runif(n)
88
89 ## standard with 'solve'
90 print(system.time(z <- solve(M, b)))
91 print(range(b - M \%*\% z))
92 stopifnot(all(abs((b - M \%*\% z)) < 2e-11))
93
94 ## Without pivoting:
95 RFoptions(pivot=PIVOT_NONE) ## (default)
96 print(system.time(z <- solvex(M, b)))
97 print(range(b - M \%*\% z))
98 stopifnot(all(abs((b - M \%*\% z)) < 2e-11))
99
100 ## Pivoting is 35% slower here:
101 RFoptions(pivot=PIVOT_DO)
102 print(system.time(z <- solvex(M, b)))
103 print(range(b - M \%*\% z))
104 stopifnot(all(abs((b - M \%*\% z)) < 2e-11))
105
106
107
108 ## SECOND EXAMPLE: low rank matrix
109 M <- x \%*\% t(x) + rev(x) \%*\% t(rev(x)) + y \%*\% t(y)
110 b1 <- M \%*\% b0
111
112 ## Without pivoting, it does not work
113 RFoptions(pivot=PIVOT_NONE)
114 #try(solve(M, b1))
115 #try(solvex(M, b1))
116
117 ## Pivoting works -- the precision however is reduced :
118 RFoptions(pivot=PIVOT_DO)
119 print(system.time(z1 <- solvex(M, b1)))
120 print(range(b1 - M \%*\% z1))
121 stopifnot(all(abs((b1 - M \%*\% z1)) < 2e-6))
122
123 ## Pivoting fails, when the equation system is not solvable:
124 b2 <- M + runif(n)
125 #try(solvex(M, b2))
126
90127
91128 }
92129
93 }
94
0 #ifndef auto_rfutils_h
1 #define auto_rfutils_h 1
2
3 #include "AutoRandomFieldsUtilsLocal.h"
4
5 #define MAXUNITS 4
6 #define MAXCHAR 18 // max number of characters for (covariance) names
7 #define RFOPTIONS "RFoptions"
8 #define isGLOBAL NA_INTEGER
9
10 #endif
0 #ifndef auto_rfutils_local_h
1 #define auto_rfutils_local_h 1
2
3 #define PIVOT_NONE 0
4 #define PIVOT_AUTO 1
5 #define PIVOT_DO 2
6 #define PIVOT_IDX 3 // IDX is not returned by RFoptions
7 #define PIVOT_UNDEFINED 4
8 #define PIVOTLAST PIVOT_UNDEFINED
9
10 #define PIVOTSPARSE_MMD 1 // for spam
11 #define PIVOTSPARSE_RCM 2 // for spam
12
13
14 #endif
0
1
2
30 /*
41 Authors
52 Martin Schlather, schlather@math.uni-mannheim.de
63
74
8 Copyright (C) 2015 Martin Schlather
5 Copyright (C) 2015 -- 2017 Martin Schlather
96
107 This program is free software; you can redistribute it and/or
118 modify it under the terms of the GNU General Public License
3128 #endif
3229 #include <R.h>
3330 #include <Rmath.h>
31 #include "AutoRandomFieldsUtils.h"
3432
33
34 #ifndef DO_PARALLEL_ALREADY_CONSIDERED
3535
3636 #ifdef _OPENMP
3737 #define DO_PARALLEL 1
4040 #undef DO_PARALLEL
4141 #endif
4242 #endif
43
44 #ifdef DO_PARALLEL
45 //#undef DO_PARALLEL
46 #endif
47
48
49 #endif // DO_PARALLEL_ALREADY_CONSIDERED
50
51
52 //#ifdef WIN32
53 //#ifdef DO_PARALLEL
54 //#undef DO_PARALLEL // make a comment to get parallel (part 1, see also part 2)
55 //#endif
56 //#endif
57
4358
4459 #define MULTIMINSIZE(S) ((S) > 20)
4560 // #define MULTIMINSIZE(S) false
5267
5368
5469 #define DOPRINT true
55 //
56 // 1
70 //// 1
5771
58 // // 1
72
5973 // // 1
6074
6175
6276 #ifdef __cplusplus
6377 extern "C" {
6478 #endif
65 // Fortran Code by Reinhard Furrer
6679 void spamcsrdns_(int*, double *, int *, int*, double*);
6780 void spamdnscsr_(int*, int*, double *, int*, double*, int*, int*, double*);
6881 void cholstepwise_(int*, int*, double*, int*, int*, int*, int*, int*,
98111 #define RF_INF R_PosInf
99112 #define T_PI M_2_PI
100113
101 #define MAXUNITS 4
102 #define MAXCHAR 18 // max number of characters for (covariance) names
103114 #define OBSOLETENAME "obsolete"
104 #define RFOPTIONS "RFoptions"
105115
106116 #define MAXINT 2147483647
117 #define MININT -2147483647
118 #define MAXUNSIGNED (MAXINT * 2) + 1
107119 #define INFDIM MAXINT
108120 #define INFTY INFDIM
109
110121
111122 #define LENGTH length // safety, in order not to use LENGTH defined by R
112123 #define complex Rcomplex
138149 #define MAX(A,B) ((A) > (B) ? (A) : (B))
139150
140151
141 #define ACOS(X) std::acos(X)
142 #define ASIN(X) std::asin(X)
143 #define ATAN(X) std::atan(X)
152 #define ACOS std::acos
153 #define ASIN std::asin
154 #define ATAN std::atan
144155 #define CEIL(X) std::ceil((double) X) // keine Klammern um X!
145 #define COS(X) std::cos(X)
146 #define EXP(X) std::exp(X)
156 #define COS std::cos
157 #define EXP std::exp
147158 #define FABS(X) std::fabs((double) X) // keine Klammern um X!
148 #define FLOOR(X) std::floor(X)
149 #define Log(X) std::log(X)
159 #define FLOOR std::floor
160 #define LOG std::log
150161 #define POW(X, Y) R_pow((double) X, (double) Y) // keine Klammern um X!
151 #define SIN(X) std::sin(X)
162 #define SIGN(X) sign((double) X)
163 #define SIN std::sin
152164 #define SQRT(X) std::sqrt((double) X)
153165 #define STRCMP(A, B) std::strcmp(A, B)
154166 #define STRCPY(A, B) std::strcpy(A, B)
155 #define STRLEN(X) std::strlen(X)
167 #define STRLEN std::strlen
156168 #define STRNCMP(A, B, C) std::strncmp(A, B, C)
157 #define TAN(X) std::tan(X)
169 #define STRNCPY(A, B, N) strcopyN(A, B, N)
170 #define TAN std::tan
158171 #define MEMCOPYX std::memcpy
172 #define MEMSET std::memset
173 #define AALLOC std::aligned_alloc
159174 #define CALLOCX std::calloc
160175 #define MALLOCX std::malloc
161176 #define FREEX std::free
162177 #define SPRINTF std::sprintf //
163 #define ROUND(X) std::round(X)
178 #define ROUND(X) ownround((double) X)
164179 #define TRUNC(X) ftrunc((double) X) // keine Klammern um X!
165180 #define QSORT std::qsort
166181
182
183 #define PRINTF Rprintf //
184 #ifdef SCHLATHERS_MACHINE
185 #ifdef DO_PARALLEL
186 #include <omp.h>
187 #undef PRINTF
188 #define PRINTF if (omp_get_num_threads() > 1) { error("\n\nnever use Rprintf/PRINTF within parallel constructions!!\n\n"); } else Rprintf // OK
167189 #endif
190 #endif
191
192 #define DOPRINTF if (!DOPRINT) {} else PRINTF
193 #define print NEVER_USE_print_or_PRINTF_WITHIN_PARALLEL /* // */
194
195
196 #endif
44 Martin Schlather, schlather@math.uni-mannheim.de
55
66
7 Copyright (C) 2015 Martin Schlather
7 Copyright (C) 2015 -- 2017 Martin Schlather
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
3434 #include "errors_messages.h"
3535 #include "kleinkram.h"
3636 #include "Solve.h"
37 #include "scalar.h"
3738
3839
39
40 #define DOPRINTF if (DOPRINT) Rprintf
41 #define PRINTF Rprintf
42 #define print PRINTF /* // */
4340
4441 #ifdef HIDE_UNUSED_VARIABLE
4542 #define VARIABLE_IS_NOT_USED __attribute__ ((unused))
5956 #define INTERNAL SERR("Sorry. This functionality does not exist currently. There is work in progress at the moment by the maintainer.")
6057 #define assert(X) {}
6158 #define BUG { \
62 SPRINTF(BUG_MSG, "Severe error occured in function '%s' (file '%s', line %d). Please contact maintainer martin.schlather@math.uni-mannheim.de .", \
59 RFERROR3("Severe error occured in function '%.50s' (file '%.50s', line %d). Please contact maintainer martin.schlather@math.uni-mannheim.de .", \
6360 __FUNCTION__, __FILE__, __LINE__); \
64 RFERROR(BUG_MSG); \
65 }
61 }
6662 #define DO_TESTS false
67 //#define MEMCOPY(A,B,C) {memcpy(A,B,C); printf("memcpy %s %d\n", __FILE__, __LINE__);}
63 //#define MEMCOPY(A,B,C) {MEMCPY(A,B,C); printf("memcpy %.50s %d\n", __FILE__, __LINE__);}
6864 #define MEMCOPY(A,B,C) MEMCOPYX(A,B,C)
65 #define AMALLOC(ELEMENTS, SIZE) AALLOC(SIZE, (SIZE) * (ELEMENTS))
6966 #define MALLOC MALLOCX
7067 #define CALLOC CALLOCX
68 #define XCALLOC CALLOCX
69 //
7170 #define FREE(X) if ((X) != NULL) {FREEX(X); (X)=NULL;}
71 //#define FREE(X) if ((X) != NULL) {printf("utils free %.50s %ld Line %d %s\n", #X, (long) X, __LINE__, __FILE__); FREEX(X); (X)=NULL;}
7272 #define UNCONDFREE(X) {FREEX(X); (X)=NULL;}
7373 #endif // not SCHLATHERS_MACHINE
7474
7979 #define MAXALLOC 1e9
8080
8181 // __extension__ unterdrueckt Fehlermeldung wegen geklammerter Argumente
82 #define INTERNAL \
83 SPRINTF(BUG_MSG, \
84 "made to be an internal function '%s' ('%s', line %d).", /* // */ \
85 __FUNCTION__, __FILE__, __LINE__); \
86 /* warning(BUG_MSG) */ \
87 SERR(BUG_MSG)
88
89 #define assert(X) if (!__extension__ (X)) { \
90 SPRINTF(BUG_MSG,"'assert(%s)' failed in function '%s'.",#X,__FUNCTION__); \
91 ERR(BUG_MSG); \
82 #define INTERNAL { \
83 RFERROR3("made to be an internal function '%.50s' ('%.50s', line %d).", \
84 __FUNCTION__, __FILE__, __LINE__); \
85 }
86
87 #define assert(X) if (!__extension__ (X)) { \
88 RFERROR3("'assert' failed in function '%.50s' (%.50s, line %d).", \
89 __FUNCTION__, __FILE__, __LINE__); \
9290 }
9391 #define SHOW_ADDRESSES 1
94 #define BUG { PRINTF("BUG in '%s'.", __FUNCTION__); ERR(BUG_MSG); }
92 #define BUG { RFERROR2("BUG in '%.50s' line %d.\n", __FUNCTION__, __LINE__);}
9593 #define DO_TESTS true
9694
97 #define MEMCOPY(A,B,C) __extension__ ({ assert((A)!=NULL && (B)!=NULL); MEMCOPYX(A,B,C); })
95 #define MEMCOPY(A,B,C) __extension__ ({ assert((A)!=NULL && (B)!=NULL && (C)>0 && (C)<=MAXALLOC); MEMCOPYX(A,B,C); })
9896 //#define MEMCOPY(A,B,C) memory_copy(A, B, C)
9997 #define MALLOC(X) __extension__ ({assert((X)>0 && (X)<=MAXALLOC); MALLOCX(X);})
10098 #define CALLOC(X, Y) __extension__({assert((X)>0 && (X)<=MAXALLOC && (Y)>0 && (Y)<=64); CALLOCX(X,Y);})
101 #define FREE(X) { if ((X) != NULL) {if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;}}
102 #define UNCONDFREE(X) { if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;}
99 #define XCALLOC(X, Y) __extension__({assert((X)>0 && (X)<=MAXALLOC && (Y)>0); CALLOCX(X,Y);})
100 #define FREE(X) { if ((X) != NULL) {if (showfree) { DOPRINTF("(free in %.50s, line %d)\n", __FILE__, __LINE__);} FREEX(X); (X)=NULL;}}
101 #define UNCONDFREE(X) { if (showfree) {DOPRINTF("(free in %.50s, line %d)\n", __FILE__, __LINE__);} FREEX(X); (X)=NULL;}
103102 #endif // SCHLATHERS_MACHINE
104103
105104
107106
108107 #ifdef RANDOMFIELDS_DEBUGGING
109108 #undef MALLOC
110 #define MALLOC(X) __extension__({DOPRINTF("(MALL %s, line %d)\n", __FILE__, __LINE__);assert((X)>0 && (X)<=3e9); MALLOCX(X);})
109 #define MALLOC(X) __extension__({DOPRINTF("(MLLC %.50s, line %d)\n", __FILE__, __LINE__);assert((X)>0 && (X)<=3e9); MALLOCX(X);})
111110 //
112111 #undef CALLOC
113 #define CALLOC(X, Y) __extension__({DOPRINTF("(CALL %s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)<MAXALLOC && (Y)>0 && (Y)<=64); CALLOCX(X,Y);})
112 #undef XCALLOC
113 #define CALLOC(X, Y) __extension__({DOPRINTF("(CLLC %.50s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)<MAXALLOC && (Y)>0 && (Y)<=216); CALLOCX(X,Y);})
114 #define XCALLOC(X, Y) __extension__({DOPRINTF("(CLLC %.50s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)<MAXALLOC && (Y)>0); CALLOCX(X,Y);})
114115 //#define MALLOC malloc
115116 //#define CALLOC calloc
116117
118
119 // note that DEBUGINDOERR is redefined in MachineDebugging.h
117120 #define DEBUGINFOERR { \
118 errorstring_type dummy_; strcpy(dummy_, ERRORSTRING); \
119 SPRINTF(ERRORSTRING, "%s (%s, line %d)\n", dummy_, __FILE__, __LINE__); \
121 errorstring_type dummy_; STRCPY(dummy_, WHICH_ERRORSTRING); \
122 SPRINTF(WHICH_ERRORSTRING, "%.50s (%.50s, line %d)\n", dummy_, __FILE__, __LINE__); \
120123 }
121 #define DEBUGINFO DOPRINTF("(currently at %s, line %d)\n", __FILE__, __LINE__)
124 #define DEBUGINFO DOPRINTF("(currently at %.50s, line %d)\n", __FILE__, __LINE__)
122125
123126 #else
124127 #define DEBUGINFO
125 #define DEBUGINFOERR if (PL >= PL_ERRORS) PRINTF("error: %s\n", ERRORSTRING);
128 #define DEBUGINFOERR if (PL >= PL_ERRORS) {PRINTF("error: %.50s\n", WHICH_ERRORSTRING);}
126129 #endif
127130
128131
132 extern int PLoffset;
129133 #define PL_IMPORTANT 1
130134 #define PL_BRANCHING 2
131135 #define PL_DETAILSUSER 3
142146 #define PL_SUBDETAILS 10
143147
144148 #define MATERN_NU_THRES 100
149 #define BESSEL_NU_THRES 100
150 #define LOW_MATERN 1e-20
151 #define LOW_BESSEL 1e-20
145152
146153
147154 #endif
148
149
0 PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
1 PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS)
0 PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(SHLIB_OPENMP_CXXFLAGS) $(FLIBS)
1 PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS)
44 Martin Schlather, schlather@math.uni-mannheim.de
55
66
7 Copyright (C) 2015 Martin Schlather
7 Copyright (C) 2015 -- 2017 Martin Schlather
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
3434
3535 #define R_PRINTLEVEL 1
3636 #define C_PRINTLEVEL 1
37 extern int PL;
37 #ifdef SCHLATHERS_MACHINE
38 #define INITCORES 4
39 #else
40 #define INITCORES 1
41 #endif
42
43 extern int PL, CORES;
3844
3945
4046 #define LEN_OPTIONNAME 201
4147
42 #define basicN 7
48 #define basicN 9
4349 // IMPORTANT: all names of basic must be at least 3 letters long !!!
4450 extern const char *basic[basicN];
4551 typedef struct basic_param {
46 bool
47 skipchecks,
48 asList;
4952 int
5053 Rprintlevel,
5154 Cprintlevel,
5255 seed, cores;
56 bool skipchecks, asList, kahanCorrection, helpinfo;
5357 } basic_param;
5458 #define basic_START \
55 { false, true, \
56 R_PRINTLEVEL, C_PRINTLEVEL, NA_INTEGER, 1 \
59 { R_PRINTLEVEL, C_PRINTLEVEL, NA_INTEGER, INITCORES, \
60 false, true, false, true \
5761 }
5862
5963
60 #define nr_InversionMethods ((int) Diagonal + 1)
61 #define nr_user_InversionMethods ((int) NoInversionMethod + 1)
6264 extern const char * InversionNames[nr_InversionMethods];
6365
64 #define PIVOT_NONE 0
65 #define PIVOT_MMD 1
66 #define PIVOT_RCM 2
6766 #define SOLVE_SVD_TOL 3
68 #define solveN 12
67 #define solveN 20
6968 typedef struct solve_param {
70 usr_bool sparse;
71 double spam_tol, spam_min_p, svd_tol, eigen2zero;
69 usr_bool sparse, pivot_check;
70 bool det_as_log;
71 double spam_tol, spam_min_p, svd_tol, eigen2zero, pivot_relerror,
72 max_deviation, max_reldeviation;
7273 InversionMethod Methods[SOLVE_METHODS];
73 int spam_min_n, spam_sample_n, spam_factor,
74 pivot, max_chol, max_svd;
74 int spam_min_n, spam_sample_n, spam_factor, pivotsparse, max_chol,
75 max_svd, pivot,
76 actual_pivot, actual_size,
77 *pivot_idx, pivot_idx_n;//permutation; phys+logi laenge
7578 // bool tmp_delete;
7679 } solve_param;
7780 #ifdef SCHLATHERS_MACHINE
7982 #else
8083 #define svd_tol_start 0
8184 #endif
82 #define solve_START \
83 { Nan, DBL_EPSILON, 0.8, svd_tol_start, 1e-12, \
84 {NoInversionMethod, NoInversionMethod}, \
85 400, 500, 4294967, PIVOT_MMD, 16384, 10000}
85 #define solve_START \
86 { Nan, False, true, \
87 DBL_EPSILON, 0.8, svd_tol_start, 1e-12, 1e-11, \
88 1e-10, 1e-10, \
89 {NoInversionMethod, NoFurtherInversionMethod}, \
90 400, 500, 4294967, PIVOTSPARSE_MMD, 16384, \
91 10000, PIVOT_NONE, /* never change -- see RFoptions.Rd */ \
92 PIVOT_UNDEFINED, 0, NULL, 0}
8693 extern const char * solve[solveN];
8794
8895
93100
94101
95102
96 typedef void (*setparameterfct) (int, int, SEXP, char[200], bool);
97 typedef void (*getparameterfct) (SEXP*);
98 typedef void (*finalsetparameterfct) ();
99 #define ADD(ELT) SET_VECTOR_ELT(sublist[i], k++, ELT);
103 typedef void (*setparameterfct) (int, int, SEXP, char[200], bool, int);
104 typedef void (*getparameterfct) (SEXP, int, int);
105 typedef void (*finalsetparameterfct) (int);
106 typedef void (*deleteparameterfct) (int);
107 #define ADD(ELT) SET_VECTOR_ELT(sublist, k++, ELT);
100108 #define ADDCHAR(ELT) x[0] = ELT; ADD(ScalarString(mkChar(x)));
101109
102110
33 Martin Schlather, schlather@math.uni-mannheim.de
44
55
6 Copyright (C) 2016 Martin Schlather
6 Copyright (C) 2016 -- 2017 Martin Schlather
77
88 This program is free software; you can redistribute it and/or
99 modify it under the terms of the GNU General Public License
2323 #include "RandomFieldsUtils.h"
2424 #include "General_utils.h"
2525 #include "own.h"
26 #include "init_RandomFieldsUtils.h"
27
28
26 #include "zzz_RandomFieldsUtils.h"
27
28
29 typedef struct {
30 int ListNr, i;
31 } getlist_type;
2932
3033
3134 void setpDef(int VARIABLE_IS_NOT_USED i,
3235 int VARIABLE_IS_NOT_USED j,
3336 SEXP VARIABLE_IS_NOT_USED el,
3437 char VARIABLE_IS_NOT_USED name[LEN_OPTIONNAME],
35 bool VARIABLE_IS_NOT_USED isList) {
38 bool VARIABLE_IS_NOT_USED isList,
39 int VARIABLE_IS_NOT_USED local) {
3640 BUG;
3741 }
38 void getpDef(SEXP VARIABLE_IS_NOT_USED *sublist) {
42 void getpDef(SEXP VARIABLE_IS_NOT_USED sublist, int VARIABLE_IS_NOT_USED i,
43 int VARIABLE_IS_NOT_USED local) {
3944 BUG;
4045 }
4146
4954
5055 #define MAXNLIST 5
5156 int NList = 0; // originally 1
52 int AllprefixN[MAXNLIST] = {ownprefixN, 0, 0, 0, 0},
57 int nbasic_options = 0,
58 AllprefixN[MAXNLIST] = {ownprefixN, 0, 0, 0, 0},
5359 *AllallN[MAXNLIST] = {ownallN, NULL, NULL, NULL, NULL};
54 const char **Allprefix[MAXNLIST] = {ownprefixlist, NULL, NULL, NULL, NULL},
60 const char *basic_options[MAXNLIST] = {ownprefixlist[1], NULL, NULL, NULL},
61 **Allprefix[MAXNLIST] = {ownprefixlist, NULL, NULL, NULL, NULL},
5562 ***Allall[MAXNLIST] = { ownall, NULL, NULL, NULL, NULL};
5663 setparameterfct setparam[MAXNLIST] =
5764 {setparameterUtils, setpDef, setpDef, setpDef, setpDef};
5865 getparameterfct getparam[MAXNLIST] =
5966 {getparameterUtils, getpDef, getpDef, getpDef, getpDef};
6067 finalsetparameterfct finalparam[MAXNLIST] = { NULL, NULL, NULL, NULL, NULL };
61
62 void setparameter(SEXP el, char *prefix, char *mainname, bool isList) {
68 deleteparameterfct delparam[MAXNLIST] = { NULL, NULL, NULL, NULL, NULL };
69
70
71 void setparameter(SEXP el, char *prefix, char *mainname, bool isList,
72 getlist_type *getlist, int local) {
6373 int
6474 j = NOMATCHING,
6575 i = NOMATCHING,
6676 ListNr = NOMATCHING;
6777 char name[LEN_OPTIONNAME];
6878
69 SPRINTF(name, "%s%s%s", prefix, strlen(prefix)==0 ? "" : ".", mainname);
70
71 // print("set param: %s.%s.%s\n",prefix, strlen(prefix)==0 ? "" : ".", mainname);
79 SPRINTF(name, "%.50s%.50s%.50s", prefix, STRLEN(prefix)==0 ? "" : ".", mainname);
80
81 // print("set param: %.50s.%.50s.%.50s\n",prefix, STRLEN(prefix)==0 ? "" : ".", mainname);
7282 // print("relax=%d\n", RELAX_UNKNOWN_RFOPTION);
7383
7484 if (mainname[0] >= 'A' && mainname[0] <= 'Z' && RELAX_UNKNOWN_RFOPTION) {
75 if (PL > PL_IMPORTANT)
76 PRINTF("'%s' is not considered as an RFoption, but will be passed to evaluate the model formula.\n", mainname);
85 if (PL > PL_IMPORTANT) {
86 PRINTF("'%.50s' is not considered as an RFoption, but will be passed to evaluate the model formula.\n", mainname);
87 }
7788 return;
7889 }
7990
8293 i = Match(prefix, Allprefix[ListNr], AllprefixN[ListNr]);
8394 if (i != NOMATCHING) break;
8495 }
85 if (i == NOMATCHING) ERR1("option prefix name '%s' not found.", prefix);
96 if (i == NOMATCHING) ERR1("option prefix name '%.50s' not found.", prefix);
8697 if (i < 0 || STRCMP(prefix, Allprefix[ListNr][i])) {
8798 for (int k=ListNr + 1; k < NList; k++) {
8899 int ii = Match(prefix, Allprefix[ListNr], AllprefixN[ListNr]);
95106 } // ii >0
96107 } // for k
97108 if (i == MULTIPLEMATCHING)
98 ERR1("option prefix name '%s' is ambiguous.", prefix);
109 ERR1("option prefix name '%.50s' is ambiguous.", prefix);
99110 } // prefix == List
100111
101112
102 // printf("ListNr = %d %s %d %s\n", ListNr, Allprefix[ListNr][i], i,
113 // printf("ListNr = %d %.50s %d %.50s\n", ListNr, Allprefix[ListNr][i], i,
103114 // mainname);
104115
105116 j = Match(mainname, Allall[ListNr][i], AllallN[ListNr][i]);
114125 }
115126 if (j != NOMATCHING) break;
116127 }
117 if (j==NOMATCHING) ERR1("Unknown option '%s'.", name);
128 if (j==NOMATCHING) ERR1("Unknown option '%.50s'.", name);
118129
119 // printf("j=%d %s\n", j, j >=0 ? Allall[ListNr][i][j] : "multi");
130 // printf("j=%d %.50s\n", j, j >=0 ? Allall[ListNr][i][j] : "multi");
120131
121132 if (j < 0 || STRCMP(mainname, Allall[ListNr][i][j])) {
122133 int starti = i + 1;
126137 int jj = Match(mainname, Allall[k][ii], AllallN[k][ii]);
127138 if (jj == NOMATCHING) continue;
128139
129 // printf("listnr=%d %s jj=%d %s\n", ListNr, Allall[ListNr][i][j],
140 // printf("listnr=%d %.50s jj=%d %.50s\n", ListNr, Allall[ListNr][i][j],
130141 // jj, jj < 0 ? "none" : Allall[k][ii][jj]);
131142 j = MULTIPLEMATCHING;
132143 if (jj >= 0 && STRCMP(mainname, Allall[k][ii][jj])==0) {
141152 } // if j < 0 || !=
142153 } // no prefix given
143154
144 if (j<0) ERR1("Multiple matching for '%s'.", name);
155 if (j<0) ERR1("Multiple matching for '%.50s'.", name);
145156
146
147 // printf("%s %d %d %d %ld \n", name, ListNr, i, j, (long) setparam[ListNr]);
148
149 setparam[ListNr](i, j, el, name, isList);
150 }
151
152
153
154
155 SEXP getRFoptions() {
157 if (getlist != NULL) {
158 int k=0;
159 while((getlist[k].ListNr != ListNr || getlist[k].i != i)
160 && getlist[k].ListNr >= 0) k++;
161 if (getlist[k].ListNr < 0)
162 ERR2("Option '%.50s' not allowed for this call.\n In case you really need this option, use the command 'RFoption(%.50s=..)'", mainname, mainname);
163 }
164 // printf("%.50s %d %d %d %ld \n", name, ListNr, i, j, (long) setparam[ListNr]);
165
166 setparam[ListNr](i, j, el, name, isList, local);
167 }
168
169
170 SEXP getRFoptions(int ListNr, int i, int local) {
171 SEXP sublist, subnames;
172 int elmts = AllallN[ListNr][i];
173 PROTECT(sublist = allocVector(VECSXP, elmts));
174 PROTECT(subnames = allocVector(STRSXP, elmts));
175 for (int k=0; k<elmts; k++) {
176 // printf("getopt %d %d %d %.50s\n", i, k, ListNr, Allall[ListNr][i][k]);
177 SET_STRING_ELT(subnames, k, mkChar(Allall[ListNr][i][k]));
178 }
179 getparam[ListNr](sublist, i, local);
180 setAttrib(sublist, R_NamesSymbol, subnames);
181 UNPROTECT(2);
182 return sublist;
183 }
184
185 SEXP getRFoptions(int local) {
156186 SEXP list, names;
157
158 int i, ListNr, itot = 0,
159 k = 0;
160 int trueprefixN, totalN;
161
187
188 int prefixN, totalN, i, ListNr,
189 itot = 0;
162190 for (totalN=ListNr=0; ListNr<NList; ListNr++) {
163 trueprefixN = AllprefixN[ListNr];
164 for (i=0; i<trueprefixN; i++) {
191 prefixN = AllprefixN[ListNr];
192 for (i=0; i<prefixN; i++) {
165193 totalN += STRCMP(Allprefix[ListNr][i], OBSOLETENAME) != 0;
166194 }
167195 }
169197 PROTECT(list = allocVector(VECSXP, totalN));
170198 PROTECT(names = allocVector(STRSXP, totalN));
171199
172 SEXP *sublist, *subnames;
173 sublist = (SEXP *) MALLOC(sizeof(SEXP) * totalN);
174 subnames = (SEXP *) MALLOC(sizeof(SEXP) * totalN);
175200 for (ListNr =0; ListNr<NList; ListNr++) {
176201 //printf("ListNr %d\n", ListNr);
177 trueprefixN = AllprefixN[ListNr];
178 for (i=0; i<trueprefixN; i++, itot++) {
202 prefixN = AllprefixN[ListNr];
203 for (i=0; i<prefixN; i++) {
179204 if (STRCMP(Allprefix[ListNr][i], OBSOLETENAME) == 0) continue;
205 SET_VECTOR_ELT(list, itot, getRFoptions(ListNr, i, local));
180206 SET_STRING_ELT(names, itot, mkChar(Allprefix[ListNr][i]));
181 PROTECT(sublist[itot] = allocVector(VECSXP, AllallN[ListNr][i]));
182 PROTECT(subnames[itot] = allocVector(STRSXP, AllallN[ListNr][i]));
183 int endfor = AllallN[ListNr][i];
184 for (k=0; k<endfor; k++) {
185 SET_STRING_ELT(subnames[itot], k, mkChar(Allall[ListNr][i][k]));
186 }
187 }
188 getparam[ListNr](sublist + itot - trueprefixN);
189 }
190
191 for (i=0; i<totalN; i++) {
192 setAttrib(sublist[i], R_NamesSymbol, subnames[i]);
193 SET_VECTOR_ELT(list, i, sublist[i]);
194 }
195 setAttrib(list, R_NamesSymbol, names);
196
197 UNPROTECT(2 + 2 * totalN);
198 FREE(sublist);
199 FREE(subnames);
207 itot ++;
208 }
209 }
210
211 setAttrib(list, R_NamesSymbol, names);
212 UNPROTECT(2);
200213
201214 return list;
202215 }
203216
204217
205 void splitAndSet(SEXP el, char *name, bool isList) {
218 void getListNr(bool save, int t, int actual_nbasic, SEXP which,
219 getlist_type *getlist,
220 int *Nr, int *idx // output
221 ){
222 int i, ListNr;
223 const char *z;
224 if (save && t < nbasic_options) z = basic_options[t];
225 else z = (char*) CHAR(STRING_ELT(which, t - actual_nbasic));
226 for (ListNr=0; ListNr<NList; ListNr++) {
227 int prefixN = AllprefixN[ListNr];
228 for (i=0; i<prefixN; i++)
229 if (STRCMP(Allprefix[ListNr][i], z) == 0) break;
230 if (i < prefixN) break;
231 }
232 if (ListNr >= NList) ERR("unknown value for 'GETOPTIONS'");
233 if (getlist != NULL) {
234 getlist[t].ListNr = ListNr;
235 getlist[t].i = i;
236 }
237 *Nr = ListNr;
238 *idx = i;
239 }
240
241
242 SEXP getRFoptions(SEXP which, getlist_type *getlist, bool save, int local) {
243 int ListNr, idx,
244 actual_nbasic = nbasic_options * save,
245 totalN = length(which) + actual_nbasic;
246
247 if (totalN == 0) return R_NilValue;
248 if (totalN == 1) {
249 getListNr(save, 0, actual_nbasic, which, getlist, &ListNr, &idx);
250 return getRFoptions(ListNr, idx, local);
251 }
252
253 SEXP list, names;
254 PROTECT(list = allocVector(VECSXP, totalN));
255 PROTECT(names = allocVector(STRSXP, totalN));
256 for (int t=0; t<totalN; t++) {
257 getListNr(save, t, actual_nbasic, which, getlist, &ListNr, &idx);
258 SET_VECTOR_ELT(list, t, getRFoptions(ListNr, idx, local));
259 SET_STRING_ELT(names, t, mkChar(Allprefix[ListNr][idx]));
260 }
261 setAttrib(list, R_NamesSymbol, names);
262 UNPROTECT(2);
263 return list;
264 }
265
266
267 void splitAndSet(SEXP el, char *name, bool isList, getlist_type *getlist,
268 int local) {
206269 int i, len;
207270 char prefix[LEN_OPTIONNAME / 2], mainname[LEN_OPTIONNAME / 2];
208271 // printf("splitandset\n");
209 len = strlen(name);
272 len = STRLEN(name);
210273 for (i=0; i < len && name[i]!='.'; i++);
211 if (i==0) { ERR1("argument '%s' not valid\n", name); }
274 if (i==0) { ERR1("argument '%.50s' not valid\n", name); }
212275 if (i==len) {
213 strcpy(prefix, "");
276 STRCPY(prefix, "");
214277 strcopyN(mainname, name, LEN_OPTIONNAME / 2);
215278 } else {
216279 strcopyN(prefix, name, MIN(i + 1, LEN_OPTIONNAME / 2));
217 strcopyN(mainname, name+i+1, MIN(strlen(name) - i, LEN_OPTIONNAME / 2) );
280 strcopyN(mainname, name+i+1, MIN(STRLEN(name) - i, LEN_OPTIONNAME / 2) );
218281 }
219282
220283 //
221 // printf("i=%d %d %s %s\n", i, len, prefix, mainname);
222 setparameter(el, prefix, mainname, isList && GLOBAL.basic.asList);
284 // printf("i=%d %d %.50s %.50s\n", i, len, prefix, mainname);
285 setparameter(el, prefix, mainname, isList && GLOBAL.basic.asList, getlist,
286 local);
223287 // printf("ende\n");
224288 }
225289
226290
227291 SEXP RFoptions(SEXP options) {
228 int i, j, lenlist, lensub;
229 SEXP el, list, sublist, names, subnames;
292 int i, j, lenlist, lensub;
293 SEXP el, list, sublist, names, subnames,
294 ans = R_NilValue;
230295 char *name, *pref;
231296 bool isList = false;
232 /*
297 int
298 local = isGLOBAL;
299
300
301 /*
233302 In case of strange values of a parameter, undelete
234303 the comment for PRINTF
235304 */
236305
237306
238 // PRINTF("start %f\n", GLOBAL.gauss.exactness);
307 // PRINTF("start %10g\n", GLOBAL.gauss.exactness);
239308 options = CDR(options); /* skip 'name' */
240 if (options == R_NilValue) {
241 // printf("before get %f\n", 1.);
242 return getRFoptions();
243 }
244
245 name = (char*) (isNull(TAG(options)) ? "" : CHAR(PRINTNAME(TAG(options))));
309 if (options == R_NilValue) return getRFoptions(local);
310
311 if (isNull(TAG(options))) name = (char*) ""; // (char*)
312 else name = (char*) CHAR(PRINTNAME(TAG(options)));
313 if (STRCMP(name, "LOCAL")==0) {
314 el = CAR(options);
315 local = INT;
316 options = CDR(options); /* skip 'name' */
317 if (isNull(TAG(options))) name = (char*) "";
318 else name = (char*) CHAR(PRINTNAME(TAG(options)));
319 }
320
246321 if ((isList = STRCMP(name, "LIST")==0)) {
247322 //printf("isList\n");
323 int n_protect = 1;
248324 list = CAR(options);
249325 if (TYPEOF(list) != VECSXP)
250 ERR1("'LIST' needs as argument the output of '%s'", RFOPTIONS);
251 names = getAttrib(list, R_NamesSymbol);
326 ERR1("'LIST' needs as argument the output of '%.50s'", RFOPTIONS);
327 PROTECT(names = getAttrib(list, R_NamesSymbol));
252328 lenlist = length(list);
253329 for (i=0; i<lenlist; i++) {
254330 int len;
255331 pref = (char*) CHAR(STRING_ELT(names, i));
256332
257 // print("%d %s\n", i, pref);
333 // print("%d %.50s\n", i, pref);
258334
259335 sublist = VECTOR_ELT(list, i);
260 len = strlen(pref);
336 len = STRLEN(pref);
261337 for (j=0; j < len && pref[j]!='.'; j++);
262338 if (TYPEOF(sublist) == VECSXP && j==len) { // no "."
263339 // so, general parameters may not be lists,
264340 // others yes
265341 lensub = length(sublist);
266 subnames = getAttrib(sublist, R_NamesSymbol);
342 PROTECT(subnames = getAttrib(sublist, R_NamesSymbol));
343 n_protect++;
267344 for (j=0; j<lensub; j++) {
268345 name = (char*) CHAR(STRING_ELT(subnames, j));
269346
270 // print(" %d %s warn.ambig=%d\n", j, name, GLOBAL.warn.ambiguous);
271
272 // print("%d %d %s : %f %f\n", i, j, name,
347 // print(" %d %.50s warn.ambig=%d\n", j, name, GLOBAL.warn.ambiguous);
348
349 // print("%d %d %.50s : %10g %10g\n", i, j, name,
273350 // GLOBAL.gauss.exactness, GLOBAL.TBM.linesimustep);
274351 //
275 // print(" %d %d pref=%s name=%s\n", i, j, pref, name);
276
352 // print(" %d %d pref=%.50s name=%.50s\n", i, j, pref, name);
353
354
277355 setparameter(VECTOR_ELT(sublist, j), pref, name,
278 isList & GLOBAL.basic.asList);
356 isList & GLOBAL.basic.asList, NULL, local);
279357 }
358 UNPROTECT(1);
280359 } else {
281 splitAndSet(sublist, pref, isList);
360 splitAndSet(sublist, pref, isList, NULL, local);
282361 }
283362 }
284 // print("end1 %f\n", GLOBAL.TBM.linesimufactor);
285 } else {
286 for(i = 0; options != R_NilValue; i++, options = CDR(options)) {
287
288 // printf("set opt i=%d\n", i);
289
363 UNPROTECT(1);
364 // print("end1 %10g\n", GLOBAL.TBM.linesimufactor);
365 } else {
366 getlist_type *getlist = NULL;
367 bool save;
368 if ((save = STRCMP(name, "SAVEOPTIONS") ==0 ) ||
369 STRCMP(name, "GETOPTIONS")==0) {
370 SEXP getoptions = CAR(options);
371 options = CDR(options);
372 if (options != R_NilValue) {
373 // printf("hier\n");
374 int len = length(getoptions) + nbasic_options * save;
375 getlist = (getlist_type *) MALLOC(sizeof(getlist_type) * (len + 1));
376 getlist[len].ListNr = -1;
377 }
378 // printf("l=%d\n", local);
379 PROTECT(ans = getRFoptions(getoptions, getlist, save, local));
380 }
381 // printf("iok %d\n", length(CAR(options)));
382 for(i = 0; options != R_NilValue; i++, options = CDR(options)) {
383 // printf("set opt i=%d\n", i);
290384 el = CAR(options);
291 name = (char*) (isNull(TAG(options)) ? "" :CHAR(PRINTNAME(TAG(options))));
292 splitAndSet(el, name, isList);
293 }
385 if (isNull(TAG(options))) name = (char*) "";
386 else name = (char*) CHAR(PRINTNAME(TAG(options)));
387 //printf("xx %.50s %d\n", name, isList);
388 splitAndSet(el, name, isList, getlist, local);
389 }
390 FREE(getlist);
294391 // print("end2\n");
295392 }
296393
297394
298395 //printf("Nlist = %d\n", NList);
299 for (i=0; i<NList; i++) if (finalparam[i] != NULL) {
396 for (i=0; i<NList; i++)
397 if (finalparam[i] != NULL) {
300398 // printf("%d %ld \n", i, (long) finalparam[i]);
301 finalparam[i]();
302 }
303
304 // printf("END\n");
305
399 finalparam[i](local);
400 }
401
402 if (ans != R_NilValue) UNPROTECT(1);
403
404
306405 GLOBAL.basic.asList = true;
307 return(R_NilValue);
406 return(ans);
308407 }
309408
310409
311
410 int PLoffset = 0;
312411 void attachRFoptions(const char **prefixlist, int N,
313 const char ***all, int *allN,
314 setparameterfct set, finalsetparameterfct final,
315 getparameterfct get) {
412 const char ***all, int *allN,
413 setparameterfct set, finalsetparameterfct final,
414 getparameterfct get,
415 deleteparameterfct del,
416 int pl_offset, bool basicopt) {
316417 for (int ListNr=0; ListNr<NList; ListNr++) {
317418 if (AllprefixN[ListNr] == N &&
318419 STRCMP(Allprefix[ListNr][0], prefixlist[0]) == 0) {
319 if (PL > 0)
320 PRINTF("options starting with prefix '%s' have been already attached.",
420 if (PL > 0) {
421 PRINTF("options starting with prefix '%.50s' have been already attached.",
321422 prefixlist[0]);
423 }
322424 return;
323425 }
324426 }
427 if (basicopt) basic_options[nbasic_options++] = prefixlist[0];
325428 if (NList >= MAXNLIST) BUG;
326429 Allprefix[NList] = prefixlist;
327430 AllprefixN[NList] = N;
330433 setparam[NList] = set;
331434 finalparam[NList] = final;
332435 getparam[NList] = get;
436 delparam[NList] = del;
333437 NList++;
438 PLoffset = pl_offset;
439 basic_param *gp = &(GLOBAL.basic);
440 PL = gp->Cprintlevel = gp->Rprintlevel + PLoffset;
441 CORES = gp->cores;
334442 }
335443
336444
342450 STRCMP(Allprefix[ListNr][0], prefixlist[0]) == 0) break;
343451 }
344452 if (ListNr >= NList) {
345 ERR1("options starting with prefix '%s' have been already attached.",
453 ERR1("options starting with prefix '%.50s' have been already detached.",
346454 prefixlist[0]);
347455 }
348456
457 if (delparam[ListNr] != NULL) delparam[ListNr](isGLOBAL);
458
459 int i;
460 for (i=0; i<nbasic_options ; i++)
461 if (STRCMP(basic_options[i], prefixlist[0]) == 0) break;
462 for (i++ ; i < nbasic_options; i++) basic_options[i - 1] = basic_options[i];
463
349464 for (ListNr++; ListNr<NList; ListNr++) {
350465 Allprefix[ListNr - 1] = Allprefix[ListNr];
351466 AllprefixN[ListNr - 1] = AllprefixN[ListNr];
357472 }
358473
359474 NList--;
475 if (NList <= 1) PLoffset = 0;
360476 }
361477
362478 void getUtilsParam(utilsparam **global) {
55 Martin Schlather, schlather@math.uni-mannheim.de
66
77
8 Copyright (C) 2015 Martin Schlather
8 Copyright (C) 2015 -- 2017 Martin Schlather
99
1010 This program is free software; you can redistribute it and/or
1111 modify it under the terms of the GNU General Public License
4949 SEXP RFoptions(SEXP options);
5050 void RelaxUnknownRFoption(int *relax);
5151
52 SEXP attachRFoptionsUtils();
53 SEXP detachRFoptionsUtils();
52 SEXP attachRandomFieldsUtils(SEXP show);
53 SEXP detachRandomFieldsUtils();
5454
5555 SEXP sortX(SEXP Data, SEXP From, SEXP To, SEXP NAlast);
5656 SEXP orderX(SEXP Data, SEXP From, SEXP To, SEXP NAlast);
6060 void hostname(char **h, int *i);
6161 void pid(int *i);
6262 SEXP getChar();
63 SEXP colMaxs(SEXP M);
64 SEXP rowMeansX(SEXP M, SEXP Factor);
65 SEXP rowProd(SEXP M);
66 SEXP chol2mv(SEXP Chol, SEXP N);
67 SEXP tcholRHS(SEXP C, SEXP RHS);
68 SEXP DivByRow(SEXP M, SEXP V);
69 SEXP quadratic(SEXP x, SEXP A);
70 SEXP dbinorm(SEXP X, SEXP Sigma);
71 SEXP dotXV(SEXP M, SEXP V);
72 void Ordering(double *d, int *len, int *dim, int *pos);
73
74
6375
6476
65 void Ordering(double *d, int *len, int *dim, int *pos);
66
6777 #ifdef SCHLATHERS_MACHINE
68 SEXP scalarX(SEXP x, SEXP y, SEXP mode);
69 SEXP brdomain(SEXP Srf, SEXP Sgamma, SEXP Sinstances, SEXP Smaxn);
70 SEXP Udiffusion(SEXP SUSc, SEXP SUCo, SEXP Snevertried,
71 SEXP Sa, SEXP Sabar, SEXP tWeight, SEXP Sq,
72 SEXP Sdt, SEXP rho, SEXP SrandSc, SEXP SrandCo,
73 SEXP Sit, SEXP Sdummy, SEXP Sthreshold);
78 // SEXP scalarX(SEXP x, SEXP y, SEXP mode);
79 // SEXP brdomain(SEXP Srf, SEXP Sgamma, SEXP Sinstances, SEXP Smaxn);
7480 #endif
7581
7682 #ifdef __cplusplus
22 Martin Schlather, schlather@math.uni-mannheim.de
33
44
5 Copyright (C) 2015 Martin Schlather
5 Copyright (C) 2015 -- 2017 Martin Schlather
66
77 This program is free software; you can redistribute it and/or
88 modify it under the terms of the GNU General Public License
1919 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
2020 */
2121
22
22 #include "errors_messages.h"
2323
2424 #ifndef rfutils_solve_H
2525 #define rfutils_solve_H 1
3333 direct_formula,
3434 Diagonal // always last one!
3535 } InversionMethod;
36 #define nr_InversionMethods ((int) Diagonal + 1)
37 #define nr_user_InversionMethods ((int) NoFurtherInversionMethod + 1)
3638
3739
3840 #define SOLVE_METHODS 3
3941 typedef struct solve_storage {
42 errorstring_type err_msg;
43 InversionMethod method, newMethods[SOLVE_METHODS];
44 usr_bool sparse;
4045 int SICH_n, MM_n, workspaceD_n, workspaceU_n, VT_n, U_n, D_n,
41 iwork_n, work_n, w2_n, ipiv_n, workLU_n, pivot_n,
46 iwork_n, work_n, w2_n, ipiv_n, workLU_n, pivotsparse_n,
4247 xlnz_n, snode_n, xsuper_n, xlindx_n, invp_n,
4348 cols_n, rows_n, DD_n, lindx_n, xja_n,
44 lnz_n, w3_n, result_n;
45 //t_cols_n, t_rows_n, t_DD_n;
46 InversionMethod method, newMethods[SOLVE_METHODS];
47 int nsuper, nnzlindx, size,
49 diagonal_n,
50 lnz_n, w3_n, result_n,
51 nsuper, nnzlindx, size, actual_size, actual_pivot,
52 *pivot_idx, pivot_idx_n,
4853 *iwork, *ipiv,
49 *pivot, *xlnz, *snode, *xsuper, *xlindx,
54 *pivotsparse, *xlnz, *snode, *xsuper, *xlindx,
5055 *invp, *cols, *rows, *lindx, *xja; //*t_cols, *t_rows;
5156 double *SICH, *MM, *workspaceD, *workspaceU,
52 *VT, *work, *w2, *U, *D, *workLU,
57 *VT, *work, *w2, *U, *D, *workLU, *diagonal,
5358 *lnz, *DD, *w3, *result,
5459 *to_be_deleted; //, *t_DD;
5560 } solve_storage;
5661
57
58
59
62 #define SOLVE 0
63 #define MATRIXSQRT 1
64 #define DETERMINANT 2
6065
6166 #endif
0 /*
1 Authors
2 Martin Schlather, schlather@math.uni-mannheim.de
3
4
5 Copyright (C) 2018 -- 2018 Martin Schlather
6
7 This program is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public License
9 as published by the Free Software Foundation; either version 3
10 of the License, or (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20 */
21
22
23 #ifndef rfutils_utils_H
24 #define rfutils_utils_H 1
25
26 extern bool ToFalse[1];
27 double *ToReal(SEXP X);
28 int *ToInt(SEXP X);
29 //double *ToRealI(SEXP X, bool *create);
30
31
32 #ifdef __cplusplus
33 extern "C" {
34 #endif
35 int *ToIntI(SEXP X, bool *create, bool round);
36 void freeGlobals();
37 // double *ToRealI(SEXP X, bool *create);
38 // int *ToIntI(SEXP X, bool *create, bool round);
39 #ifdef __cplusplus
40 }
41 #endif
42
43
44
45 #endif
0 c
1 c Authors:
2 c Reinhard Furrer
3 c
4 c Copyright (C) 2017 -- 2017 Reinhard Furrer
5 c
6 c This program is free software; you can redistribute it and/or
7 c modify it under the terms of the GNU General Public License
8 c as published by the Free Software Foundation; either version 3
9 c of the License, or (at your option) any later version.
10 c
11 c This program is distributed in the hope that it will be useful,
12 c but WITHOUT ANY WARRANTY; without even the implied warranty of
13 c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 c GNU General Public License for more details.
15 c
16 c You should have received a copy of the GNU General Public License
17 c along with this program; if not, write to the Free Software
18 c Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19
20
021 subroutine backsolve(m,nsuper,nrhs,lindx,xlindx,lnz,
122 & xlnz,xsuper,b)
223 c see below...
33
44 Collection of system specific auxiliary functions
55
6 Copyright (C) 2001 -- 2015 Martin Schlather,
6 Copyright (C) 2001 -- 2017 Martin Schlather,
77
88 This program is free software; you can redistribute it and/or
99 modify it under the terms of the GNU General Public License
6060 pois += e;
6161 int
6262 x0 = (int) (UNIFORM_RANDOM * nloc);
63 if (t==1) PRINTF(" pois=%f e=%f %d : ", pois, e, x0);
63 if (t==1) { PRINTF(" pois=%10g e=%10g %d : ", pois, e, x0);}
6464 double
6565 *field = rf + nloc * (int) (UNIFORM_RANDOM * N),
6666 *s2 = sigma2 + x0 * nloc,
67 uz0 = - Log(pois) - field[x0];
67 uz0 = - LOG(pois) - field[x0];
6868
6969 for (int j=0; j<nloc; j++) {
7070 if (j == x0 && field[j] != field[x0]) BUG;
7171 double w = uz0 + field[j] - s2[j];
72 if (t==1 && j == 97-68 - 1 && (m <= 10))
73 PRINTF("j=%d %f %f u=%f\n", j, w, ans[j], - Log(pois));
74 if (t==1 && j == 97-68 - 1 && x0==j)
75 PRINTF("\nGREAT j=%d %f %f u=%f\n", j, w, ans[j], - Log(pois));
72 if (t==1 && j == 97-68 - 1 && (m <= 10)) {
73 PRINTF("j=%d %10g %10g u=%10g\n", j, w, ans[j], - LOG(pois));
74 }
75 if (t==1 && j == 97-68 - 1 && x0==j) {
76 PRINTF("\nGREAT j=%d %10g %10g u=%10g\n", j, w, ans[j], - LOG(pois));
77 }
7678 if (w > ans[j]) ans[j] = w;
7779 }
7880 }
0 c
1 c Authors:
2 c Reinhard Furrer
3 c
4 c Copyright (C) 2017 -- 2017 Reinhard Furrer
5 c
6 c This program is free software; you can redistribute it and/or
7 c modify it under the terms of the GNU General Public License
8 c as published by the Free Software Foundation; either version 3
9 c of the License, or (at your option) any later version.
10 c
11 c This program is distributed in the hope that it will be useful,
12 c but WITHOUT ANY WARRANTY; without even the implied warranty of
13 c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 c GNU General Public License for more details.
15 c
16 c You should have received a copy of the GNU General Public License
17 c along with this program; if not, write to the Free Software
18 c Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19
20
021 subroutine updatefactor( m,nnzd,
122 & d,jd,id, invp,perm,
223 & lindx,xlindx, nsuper,lnz,xlnz,
372393 C
373394 C
374395 YOFF1 = 0
396 IY1 = 0
375397 DO 200 ICOL = 1, Q
376398 YCOL = LDA - RELIND(ICOL)
377399 LBOT1 = XLNZ(YCOL+1) - 1
+0
-96
src/diffusion.cc less more
0 /*
1 Authors
2 Martin Schlather, schlather@math.uni-mannheim.de
3
4 Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer, Martin Kroll
5
6 This program is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public License
8 as published by the Free Software Foundation; either version 3
9 of the License, or (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19 */
20
21 #include "Basic_utils.h" // must be before anything else
22 #ifdef DO_PARALLEL
23 #include <omp.h>
24 #endif
25 #include <R.h>
26 #include <R_ext/Lapack.h>
27 #include "RandomFieldsUtils.h"
28 #include "own.h"
29 #include "init_RandomFieldsUtils.h"
30 #include "kleinkram.h"
31
32 SEXP Udiffusion(SEXP SUSc, SEXP SUCo, SEXP Snevertried,
33 SEXP Sa, SEXP Sabar, SEXP StWeight, SEXP Sq, SEXP Sdt,
34 SEXP Srho, SEXP SrandSc, SEXP SrandCo, SEXP Sit, SEXP Sdummy,
35 SEXP Sthreshold) {
36 #define r_per_step 2
37 int
38 *nevertried = INTEGER(Snevertried),
39 repN = length(SUSc),
40 N = nrows(Snevertried),
41 rep = ncols(Snevertried),
42 it = INTEGER(Sit)[0]
43 ;
44 double
45 *USc = REAL(SUSc),
46 *UCo = REAL(SUCo),
47 *a = REAL(Sa),
48 *abar = REAL(Sabar),
49 *tWeight = REAL(StWeight),
50 *q = REAL(Sq),
51 dt = REAL(Sdt)[0],
52 *randSc = REAL(SrandSc) + it * repN,
53 *randCo = REAL(SrandCo) + it * repN,
54 *dummy = REAL(Sdummy),
55 rho = REAL(Srho)[0],
56 threshold = REAL(Sthreshold)[0]
57 ;
58
59 SEXP Ans;
60 PROTECT(Ans = allocVector(INTSXP, rep));
61 int *dN = INTEGER(Ans);
62 GetRNGstate();
63 #ifdef DO_PARALLEL
64 #pragma omp parallel for
65 #endif
66 for (int r=0; r<rep; r++) {
67 //
68 // printf("r=%d\n", r);
69 double *usc = USc + N * r,
70 *uco = UCo + N * r,
71 *uscnew = dummy + N * r, // zwingend so gross wegen o m p !
72 *RSc = randSc + N * r,
73 *RCo = randCo + N * r,
74 qr = q[r];
75 int *never = nevertried + N * r,
76 deltaN = 0;
77 // printf("ok %d\n", N);
78 xA(usc, tWeight, N, N, uscnew);
79 // printf("ok\n");
80 for (int i=0; i<N; i++) {
81 // printf("i=%d\n", i);
82 usc[i] += (rho * uscnew[i] + qr) * dt + RSc[i];
83 uco[i] += RCo[i];
84 if (never[i] && a[i] * usc[i] + abar[i] * uco[i] >= threshold) {
85 never[i] = false;
86 deltaN++;
87 }
88 }
89 dN[r] = deltaN;
90 }
91
92 PutRNGstate();
93 UNPROTECT(1);
94 return(Ans);
95 }
44 Martin Schlather, schlather@math.uni-mannheim.de
55
66
7 Copyright (C) 2015 Martin Schlather
7 Copyright (C) 2015 -- 2017 Martin Schlather
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
3131 #define NOERROR 0
3232 #define ERRORMEMORYALLOCATION 1
3333 #define ERRORFAILED 2 /* method didn't work for the specified parameters */
34 #define ERRORM 3 /* a single error message */
35 #define ERRORNOTPROGRAMMEDYET 4
36
34 #define ERRORNOTPROGRAMMEDYET 3
35 #define ERRORM 4 /* a single error message */
36 #define ERRORMEND 12 /* a single error message -- und alles dazwischen */
3737
3838
39 #ifdef SCHLATHERS_MACHINE
40 #define ERRLINE PRINTF("(ERROR in %s, line %d)\n", __FILE__, __LINE__);
41 #else
42 #define ERRLINE
43 #endif
44
45
46 #define LENMSG 250
39
40 #define LENMSG 1000
4741 #define MAXERRORSTRING 1000
4842 #define nErrorLoc 1000
49 #define LENERRMSG 2000
43 #define LENERRMSG 1000
5044 typedef char errorstring_type[MAXERRORSTRING];
5145 typedef char errorloc_type[nErrorLoc];
46
47
48 #ifdef DO_PARALLEL
49 #define LOCAL_ERRMSG2 char MSG2[LENERRMSG]
50 #ifndef LOCAL_ERRLOC_MSG
51 #define LOCAL_ERRLOC_MSG errorloc_type ERROR_LOC=""; char ERRMSG[LENERRMSG];
52 #endif
53 #ifndef LOCAL_ERRORSTRING
54 #define LOCAL_ERRORSTRING errorstring_type ERRORSTRING
55 #endif
56
57 #else // not DO_PARALLEL
58
59 #define LOCAL_ERRMSG2
60 #ifndef LOCAL_ERRLOC_MSG
61 #define LOCAL_ERRLOC_MSG
62 #endif
63 #ifndef LOCAL_ERRORSTRING
64 #define LOCAL_ERRORSTRING
65 #endif
5266 extern char ERRMSG[LENERRMSG], // used by Error_utils.h. Never use elsewhere
53 MSG[LENERRMSG], // used by RandomFields in intermediate steps
54 BUG_MSG[LENMSG],// not much used
5567 MSG2[LENERRMSG];// used at the same time with MSG and ERR()
56 extern errorstring_type ERRORSTRING; // used by ERRORM in RandomFields
68 extern errorstring_type ERRORSTRING; // used by ERRORM in RandomFields
69
70 #ifndef ERROR_LOC
5771 extern errorloc_type ERROR_LOC;
58
59 #define ERRMSG(X) if (PL>=PL_ERRORS){errorMSG(X,MSG); PRINTF("error: %s%s\n",ERROR_LOC,MSG);}
72 #endif
73 // extern char MSG[LENERRMSG]; // used by RandomFields in intermediate steps
74 #endif
75
76 #endif
77
78 #ifndef WHICH_ERRORSTRING
79 #define WHICH_ERRORSTRING ERRORSTRING
80 #endif
81
82 #ifndef LOCAL_ERROR
83 #define LOCAL_ERROR(N) {}
84 #endif
85
86
87 // #define ERRMSG(X) if (PL>=PL_ERRORS){errorMSG(X,MSG); PRINTF("error: %.50s%.50s\n",ERROR_LOC,MSG);}
88
89
90
91 #ifdef SCHLATHERS_MACHINE
92 #define ERRLINE0 PRINTF("(ERROR in %.50s, line %d)\n", __FILE__, __LINE__); LOCAL_ERRLOC_MSG
93 //#define ERRLINE ERRLINE0; LOCAL_ERRMSG2
94 #else
95 #define ERRLINE0 LOCAL_ERRLOC_MSG
96 #endif
97 #define ERRLINE ERRLINE0; LOCAL_ERRMSG2
98
99
100 #define W_ERRLINE0 char W_ERRMSG[LENERRMSG]
101 #define W_ERRLINE char W_MSG2[LENERRMSG]
60102
61103
62104 #define RFERROR error
63 #define ERR(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFERROR(ERRMSG);}
64 #define ERR1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
65 SPRINTF(MSG2, ERRMSG, Y); \
66 RFERROR(MSG2);}
67 #define ERR2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\
68 SPRINTF(MSG2, ERRMSG, Y, Z); \
69 RFERROR(MSG2);}
70 #define ERR3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
71 SPRINTF(MSG2, ERRMSG, Y, Z, A); \
72 RFERROR(MSG2);}
73 #define ERR4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
74 SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \
75 RFERROR(MSG2);}
76 #define ERR5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \
77 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \
78 RFERROR(MSG2);}
79 #define ERR6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
80 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \
81 RFERROR(MSG2);}
82 #define ERR7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
83 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \
84 RFERROR(MSG2);}
85 #define ERR8(X,Y,Z,A,B,C,D,E,F) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
86 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E, F); \
87 RFERROR(MSG2);}
88 #define FERR(X) strcpy(ERRORSTRING, X); DEBUGINFOERR
89 #define SERR(X) { FERR(X); return ERRORM;}
90 #define CERR(X) { FERR(X); err=ERRORM; continue;}
91 #define FERR1(X,Y) SPRINTF(ERRORSTRING, X, Y); DEBUGINFOERR
92 #define SERR1(X,Y) { FERR1(X, Y); return ERRORM;}
93 #define CERR1(X,Y) { FERR1(X, Y); err=ERRORM; continue; }
94 #define FERR2(X,Y,Z) SPRINTF(ERRORSTRING, X, Y, Z); DEBUGINFOERR
95 #define SERR2(X, Y, Z) { FERR2(X, Y, Z); return ERRORM;}
96 #define CERR2(X, Y, Z) { FERR2(X, Y, Z); err=ERRORM; continue;}
97 #define FERR3(X,Y,Z,A) SPRINTF(ERRORSTRING, X, Y, Z, A); DEBUGINFOERR
98 #define SERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); return ERRORM;}
99 #define CERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); err=ERRORM; continue;}
100 #define FERR4(X,Y,Z,A,B) SPRINTF(ERRORSTRING, X, Y, Z, A, B); DEBUGINFOERR
101 #define SERR4(X, Y, Z, A, B) { FERR4(X, Y, Z, A, B); return ERRORM;}
102 #define FERR5(X,Y,Z,A,B,C) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C); DEBUGINFOERR
103 #define SERR5(X, Y, Z, A, B, C) {FERR5(X, Y, Z, A, B, C); return ERRORM;}
104 #define FERR6(X,Y,Z,A,B,C,D) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D); DEBUGINFOERR
105 #define SERR6(X, Y, Z, A, B, C, D) {FERR6(X, Y, Z, A, B, C,D); return ERRORM;}
106 #define FERR7(X,Y,Z,A,B,C,D,E) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D,E);DEBUGINFOERR
107 #define SERR7(X, Y, Z, A, B, C, D, E) {FERR7(X,Y,Z,A,B,C,D,E); return ERRORM;}
108 #define GERR(X) {FERR(X); err = ERRORM; goto ErrorHandling;}
109 #define GERR1(X,Y) {FERR1(X,Y);err = ERRORM; goto ErrorHandling;}
110 #define GERR2(X,Y,Z) {FERR2(X,Y,Z); err = ERRORM; goto ErrorHandling;}
111 #define GERR3(X,Y,Z,A) {FERR3(X,Y,Z,A); err = ERRORM; goto ErrorHandling;}
112 #define GERR4(X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); err = ERRORM; goto ErrorHandling;}
113 #define GERR5(X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); err=ERRORM; goto ErrorHandling;}
114 #define GERR6(X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); err=ERRORM; goto ErrorHandling;}
105 #define ERR(X) {ERRLINE0;SPRINTF(ERRMSG, "%.90s %.790s",ERROR_LOC,X);RFERROR(ERRMSG);}
106 #define ERR00(X) ERRLINE;SPRINTF(ERRMSG, "%.90s %.790s", ERROR_LOC, X)
107 #define ERR1(X, Y) {ERR00(X); SPRINTF(MSG2, ERRMSG, Y); RFERROR(MSG2);}
108 #define ERR2(X, Y, Z) {ERR00(X); SPRINTF(MSG2, ERRMSG, Y, Z); RFERROR(MSG2);}
109 #define ERR3(X, Y, Z, A) {ERR00(X); SPRINTF(MSG2, ERRMSG,Y,Z,A); RFERROR(MSG2);}
110 #define ERR4(X, Y, Z, A, B) {ERR00(X); SPRINTF(MSG2,ERRMSG,Y,Z,A,B); \
111 RFERROR(MSG2);}
112 #define ERR5(X, Y, Z, A, B, C) {ERR00(X); SPRINTF(MSG2, ERRMSG,Y,Z,A,B,C); \
113 RFERROR(MSG2);}
114 #define ERR6(X, Y, Z, A, B,C,D) {ERR00(X); SPRINTF(MSG2, ERRMSG,Y,Z,A,B,C,D); \
115 RFERROR(MSG2);}
116 #define ERR7(X, Y, Z,A,B,C,D,E) {ERR00(X); SPRINTF(MSG2,ERRMSG,Y,Z,A,B,C,D,E); \
117 RFERROR(MSG2);}
118 #define ERR8(X,Y,Z,A,B,C,D,E,F){ERR00(X);SPRINTF(MSG2,ERRMSG,Y,Z,A,B,C,D,E,F); \
119 RFERROR(MSG2);}
120
121 #define FERR(X) LOCAL_ERRORSTRING; STRCPY(WHICH_ERRORSTRING, X); DEBUGINFOERR
122 #define FERR1(X,Y) LOCAL_ERRORSTRING; \
123 SPRINTF(WHICH_ERRORSTRING, X, Y); DEBUGINFOERR
124 #define FERR2(X,Y,Z) LOCAL_ERRORSTRING; \
125 SPRINTF(WHICH_ERRORSTRING, X, Y, Z); DEBUGINFOERR
126 #define FERR3(X,Y,Z,A) LOCAL_ERRORSTRING; \
127 SPRINTF(WHICH_ERRORSTRING, X, Y, Z, A); DEBUGINFOERR
128 #define FERR4(X,Y,Z,A,B) LOCAL_ERRORSTRING; \
129 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B); DEBUGINFOERR
130 #define FERR5(X,Y,Z,A,B,C) LOCAL_ERRORSTRING; \
131 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B,C); DEBUGINFOERR
132 #define FERR6(X,Y,Z,A,B,C,D) LOCAL_ERRORSTRING; \
133 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B,C,D); DEBUGINFOERR
134 #define FERR7(X,Y,Z,A,B,C,D,E) LOCAL_ERRORSTRING; \
135 SPRINTF(WHICH_ERRORSTRING,X,Y,Z,A,B,C,D,E); DEBUGINFOERR
136
137 #define NERR00(N) LOCAL_ERROR(N); return N;
138 #define NERR(N,X) {FERR(X); NERR00(N)}
139 #define NERR1(N,X,Y) { FERR1(X, Y); NERR00(N)}
140 #define NERR2(N,X, Y, Z) { FERR2(X, Y, Z); NERR00(N)}
141 #define NERR3(N,X, Y, Z, A) { FERR3(X, Y, Z, A); NERR00(N)}
142 #define NERR4(N,X, Y, Z, A, B) { FERR4(X, Y, Z, A, B); NERR00(N)}
143 #define NERR5(N,X, Y, Z, A, B, C) { FERR5(X, Y, Z, A, B, C); NERR00(N)}
144 #define NERR6(N,X, Y, Z, A, B, C, D) { FERR6(X, Y, Z, A,B,C,D); NERR00(N)}
145 #define NERR7(N,X,Y,Z, A, B, C, D, E) { FERR7(X,Y,Z,A,B,C,D,E); NERR00(N)}
146
147 #define SERR(X) NERR(ERRORM, X)
148 #define SERR1(X,Y) NERR1(ERRORM, X, Y)
149 #define SERR2(X,Y,Z) NERR2(ERRORM, X, Y, Z)
150 #define SERR3(X,Y,Z, A) NERR3(ERRORM, X, Y, Z, A)
151 #define SERR4(X,Y,Z, A, B) NERR4(ERRORM, X, Y, Z, A, B)
152 #define SERR5(X,Y,Z, A, B, C) NERR5(ERRORM, X, Y, Z, A, B, C)
153 #define SERR6(X,Y,Z, A, B, C, D) NERR6(ERRORM, X, Y, Z, A, B, C, D)
154 #define SERR7(X,Y,Z, A, B, C, D, E) NERR7(ERRORM, X, Y, Z, A, B, C, D, E)
155
156 #define CERR00 err=ERRORM; continue;
157 #define CERR(X) { FERR(X); CERR00}
158 #define CERR1(X,Y) { FERR1(X, Y); CERR00}
159 #define CERR2(X, Y, Z) { FERR2(X, Y, Z); CERR00}
160 #define CERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); CERR00}
161
162
163 #define GERR00 LOCAL_ERROR(ERRORM); err = ERRORM; goto ErrorHandling;
164 #define GERR(X) {FERR(X); GERR00}
165 #define GERR1(X,Y) {FERR1(X,Y); GERR00}
166 #define GERR2(X,Y,Z) {FERR2(X,Y,Z); GERR00}
167 #define GERR3(X,Y,Z,A) {FERR3(X,Y,Z,A); GERR00}
168 #define GERR4(X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); GERR00}
169 #define GERR5(X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); GERR00}
170 #define GERR6(X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); GERR00}
171
172 #define GNERR00(N) err = N; goto ErrorHandling;
173 #define GNERR(N,X) {FERR(X); GNERR00(N)}
174 #define GNERR1(N,X,Y) {FERR1(X,Y);GNERR00(N)}
175 #define GNERR2(N,X,Y,Z) {FERR2(X,Y,Z); GNERR00(N)}
176 #define GNERR3(N,X,Y,Z,A) {FERR3(X,Y,Z,A); GNERR00(N)}
177 #define GNERR4(N,X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); GNERR00(N)}
178 #define GNERR5(N,X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); GNERR00(N)}
179 #define GNERR6(N,X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); GNERR00(N)}
115180
116181 #define RFWARNING warning
117 #define warn(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFWARNING(ERRMSG);}
118 #define WARN1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
119 SPRINTF(MSG2, ERRMSG, Y); \
120 RFWARNING(MSG2);}
121 #define WARN2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\
122 SPRINTF(MSG2, ERRMSG, Y, Z); \
123 RFWARNING(MSG2);}
124 #define WARN3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
125 SPRINTF(MSG2, ERRMSG, Y, Z, A); \
126 RFWARNING(MSG2);}
127 #define WARN4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \
128 SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \
129 RFWARNING(MSG2);}
130 #define WARN5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \
131 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \
132 RFWARNING(MSG2);}
133 #define WARN6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
134 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \
135 RFWARNING(MSG2);}
136 #define WARN7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \
137 SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \
138 RFWARNING(MSG2);}
139
140
141 #endif
182 #define warn(X) {RFWARNING(X);}
183 #define WARN0 warn
184 #define WARN1(X, Y) {W_ERRLINE; \
185 SPRINTF(W_MSG2, X, Y); RFWARNING(W_MSG2);}
186 #define WARN2(X, Y, Z) {W_ERRLINE; \
187 SPRINTF(W_MSG2, X, Y, Z); RFWARNING(W_MSG2);}
188 #define WARN3(X, Y, Z, A) {W_ERRLINE;\
189 SPRINTF(W_MSG2, X, Y, Z, A); RFWARNING(W_MSG2);}
190 #define WARN4(X, Y, Z, A, B) {W_ERRLINE; \
191 SPRINTF(W_MSG2, X, Y, Z, A, B); RFWARNING(W_MSG2);}
192 #define WARN5(X, Y, Z, A, B, C) {W_ERRLINE; \
193 SPRINTF(W_MSG2, X, Y, Z, A, B, C); RFWARNING(W_MSG2);}
194 #define WARN6(X, Y, Z, A, B,C,D) {W_ERRLINE; \
195 SPRINTF(W_MSG2, X, Y, Z, A, B, C, D); RFWARNING(W_MSG2);}
196 #define WARN7(X, Y, Z,A,B,C,D,E) {W_ERRLINE; \
197 SPRINTF(W_MSG2, X, Y, Z, A, B, C, D, E); RFWARNING(W_MSG2);}
198
199
200 #define RFERROR1(M,A) {errorstring_type ERR_STR; \
201 SPRINTF(ERR_STR, M, A); RFERROR(ERR_STR);}
202 #define RFERROR2(M,A,B) {errorstring_type ERR_STR; \
203 SPRINTF(ERR_STR, M, A,B); RFERROR(ERR_STR);}
204 #define RFERROR3(M,A,B,C) {errorstring_type ERR_STR;\
205 SPRINTF(ERR_STR, M, A,B,C); RFERROR(ERR_STR);}
206 #define RFERROR4(M,A,B,C,D) {errorstring_type ERR_STR; \
207 SPRINTF(ERR_STR, M, A,B,C,D); RFERROR(ERR_STR);}
208 #define RFERROR5(M,A,B,C,D,E) {errorstring_type ERR_STR; \
209 SPRINTF(ERR_STR, M, A,B,C,D,E); RFERROR(ERR_STR);}
210 #define RFERROR6(M,A,B,C,D,E,F) {errorstring_type ERR_STR;\
211 SPRINTF(ERR_STR, M, A,B,C,D,E,F); RFERROR(ERR_STR);}
212 #define RFERROR7(M,A,B,C,D,E,F,G) {errorstring_type ERR_STR;\
213 SPRINTF(ERR_STR, M, A,B,C,D,E,F,G); RFERROR(ERR_STR);}
+0
-134
src/init_RandomFieldsUtils.c less more
0 /*
1 Authors
2 Martin Schlather, schlather@math.uni-mannheim.de
3
4 Copyright (C) 2015 -- 2017 Martin Schlather, Reinhard Furrer
5
6 This program is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public License
8 as published by the Free Software Foundation; either version 3
9 of the License, or (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19 */
20
21 //#include "Basic_utils.h" // must be before anything else
22
23 #include "RandomFieldsUtils.h"
24 #include "init_RandomFieldsUtils.h"
25
26 static R_NativePrimitiveArgType Relax_t[] = { LGLSXP },
27 int_arg[] = { INTSXP },
28 host_arg[] = { STRSXP, INTSXP};
29 // static R_NativeArgStyle argin[] = {R_ARG_IN},
30 // argout[] = {R_ARG_OUT},
31 // hostarg[] = {R_ARG_OUT, R_ARG_OUT};
32 static const R_CMethodDef cMethods[] = {
33 {"RelaxUnknownRFoption", (DL_FUNC) &RelaxUnknownRFoption, 1, Relax_t},
34 {"sleepMilli", (DL_FUNC) &sleepMilli, 1, int_arg},
35 {"sleepMicro", (DL_FUNC) &sleepMicro, 1, int_arg},
36 {"pid", (DL_FUNC) &pid, 1, int_arg},
37 {"hostname", (DL_FUNC) &hostname, 2, host_arg},
38 // {"attachRFoptionsUtils", (DL_FUNC) &attachRFoptionsUtils, 0, NULL, NULL},
39 // {"detachRFoptionsUtils", (DL_FUNC) &detachRFoptionsUtils, 0, NULL, NULL},
40 {NULL, NULL, 0, NULL}
41 };
42
43
44
45 #define CALLDEF_DO(name, n) {#name, (DL_FUNC) &name, n}
46 static R_CallMethodDef callMethods[] = {
47 // in die respectiven C-Dateien muss RandomFieldsUtils.h eingebunden sein
48 CALLDEF_DO(Chol, 1),
49 CALLDEF_DO(SolvePosDef, 3),
50 CALLDEF_DO(struve, 4),
51 CALLDEF_DO(I0ML0, 1),
52 CALLDEF_DO(gaussr, 2),
53 CALLDEF_DO(WMr, 4),
54 CALLDEF_DO(logWMr, 4),
55 CALLDEF_DO(attachRFoptionsUtils, 0),
56 CALLDEF_DO(detachRFoptionsUtils, 0),
57 CALLDEF_DO(sortX, 4),
58 CALLDEF_DO(orderX, 4),
59 CALLDEF_DO(getChar, 0),
60 #ifdef SCHLATHERS_MACHINE
61 CALLDEF_DO(scalarX, 3),
62 CALLDEF_DO(brdomain, 4),
63 CALLDEF_DO(Udiffusion, 14),
64 #endif
65 // CALLDEF_DO(),
66 {NULL, NULL, 0}
67 };
68
69
70
71
72 #define EXTDEF_DO(name, n) {#name, (DL_FUNC) &name, n}
73 static const R_ExternalMethodDef extMethods[] = {
74 // in die respectiven C-Dateien muss RandomFieldsUtils.h eingebunden sein
75 EXTDEF_DO(RFoptions, -1),
76 {NULL, NULL, 0}
77 };
78
79
80
81
82 #define CALLABLE(FCTN) R_RegisterCCallable("RandomFieldsUtils", #FCTN, (DL_FUNC) FCTN)
83 void R_init_RandomFieldsUtils(DllInfo *dll) {
84 CALLABLE(solve_DELETE);
85 CALLABLE(solve_NULL);
86 CALLABLE(solvePosDef);
87 CALLABLE(invertMatrix);
88
89 CALLABLE(sqrtPosDef);
90 CALLABLE(sqrtPosDefFree);
91 CALLABLE(sqrtRHS);
92
93 CALLABLE(StruveH);
94 CALLABLE(StruveL);
95 CALLABLE(I0mL0);
96
97 CALLABLE(WM);
98 CALLABLE(DWM);
99 CALLABLE(DDWM);
100 CALLABLE(D3WM);
101 CALLABLE(D4WM);
102 CALLABLE(logWM);
103
104 CALLABLE(Gauss);
105 CALLABLE(DGauss);
106 CALLABLE(DDGauss);
107 CALLABLE(D3Gauss);
108 CALLABLE(D4Gauss);
109 CALLABLE(logGauss);
110
111 CALLABLE(getErrorString);
112 CALLABLE(setErrorLoc);
113 CALLABLE(getUtilsParam);
114 CALLABLE(attachRFoptions);
115 CALLABLE(detachRFoptions);
116 CALLABLE(relaxUnknownRFoption);
117
118 CALLABLE(ordering);
119 CALLABLE(orderingInt);
120 CALLABLE(sorting);
121 CALLABLE(sortingInt);
122
123 R_registerRoutines(dll, cMethods, callMethods, NULL, // .Fortran
124 extMethods);
125 R_useDynamicSymbols(dll, FALSE);
126 }
127
128
129
130 void R_unload_RandomFieldsUtils(DllInfo *info) {
131 /* Release resources. */
132 }
133
+0
-212
src/init_RandomFieldsUtils.h less more
0
1
2
3 /*
4 Authors
5 Martin Schlather, schlather@math.uni-mannheim.de
6
7
8 Copyright (C) 2015 Martin Schlather
9
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 3
13 of the License, or (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 */
24
25 #ifndef rfutils_init_H
26 #define rfutils_init_H 1
27
28 #include "Options_utils.h"
29 #include "errors_messages.h"
30
31
32
33 #ifdef HAVE_VISIBILITY_ATTRIBUTE
34 # define attribute_hidden __attribute__ ((visibility ("hidden")))
35 #else
36 # define attribute_hidden
37 #endif
38
39 #ifdef __cplusplus
40 extern "C" {
41 #endif
42
43 #define RF_UTILS "RandomFieldsUtils"
44 //#define FCT_PREFIX RU_
45 #define CALL0(V, N) \
46 V attribute_hidden RU_##N() { \
47 static V(*fun)(AV) = NULL; \
48 if (fun == NULL) fun = (V (*) ()) R_GetCCallable(RF_UTILS, #N); \
49 return fun(); }
50 #define DECLARE0(V, N) \
51 typedef V (*N##_type)(); \
52 /* extern N##_type Ext_##N; */ \
53 V attribute_hidden RU_##N(); \
54 V N();
55
56 #define CALL1(V, N, AV, AN) \
57 /* N##_type Ext_##N = NULL; */ \
58 V attribute_hidden RU_##N(AV AN) { \
59 static N##_type fun = NULL; \
60 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
61 return fun(AN); }
62 #define DECLARE1(V, N, AV, AN) \
63 typedef V (*N##_type)(AV AN); \
64 /* extern N##_type Ext_##N; */ \
65 V attribute_hidden RU_##N(AV AN); \
66 V N(AV AN);
67
68 #define CALL2(V, N, AV, AN, BV, BN) \
69 /* N##_type Ext_##N = NULL; */ \
70 V attribute_hidden RU_##N(AV AN, BV BN) { \
71 static N##_type fun = NULL; \
72 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
73 return fun(AN, BN); }
74 #define DECLARE2(V, N, AV, AN, BV, BN) \
75 typedef V (*N##_type)(AV AN, BV BN); \
76 /* extern N##_type Ext_##N; */ \
77 V attribute_hidden RU_##N(AV AN, BV BN); \
78 V N(AV AN, BV BN);
79
80 #define CALL3(V, N, AV, AN, BV, BN, CV, CN) \
81 /* N##_type Ext_##N = NULL; */ \
82 V attribute_hidden RU_##N(AV AN, BV BN, CV CN) { \
83 static N##_type fun = NULL; \
84 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
85 return fun(AN, BN, CN); }
86 #define DECLARE3(V, N, AV, AN, BV, BN, CV, CN) \
87 typedef V (*N##_type)(AV AN, BV BN, CV CN); \
88 /* extern N##_type Ext_##N; */ \
89 V attribute_hidden RU_##N(AV AN, BV BN, CV CN); \
90 V N(AV AN, BV BN, CV CN);
91
92 #define CALL4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
93 /* N##_type Ext_##N = NULL; */ \
94 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN) { \
95 static N##_type fun = NULL; \
96 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
97 return fun(AN, BN, CN, DN); }
98 #define DECLARE4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
99 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN); \
100 /* extern N##_type Ext_##N; */ \
101 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN); \
102 V N(AV AN, BV BN, CV CN, DV DN);
103
104 #define CALL5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
105 /* N##_type Ext_##N = NULL; */ \
106 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN) { \
107 static N##_type fun = NULL; \
108 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
109 return fun(AN, BN, CN, DN, EN); }
110 #define DECLARE5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
111 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN); \
112 /* extern N##_type Ext_##N; */ \
113 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN); \
114 V N(AV AN, BV BN, CV CN, DV DN, EV EN);
115
116 #define CALL6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
117 /* N##_type Ext_##N = NULL; */ \
118 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN) { \
119 static N##_type fun = NULL; \
120 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
121 return fun(AN, BN, CN, DN, EN, FN); }
122 #define DECLARE6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
123 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
124 /* extern N##_type Ext_##N; */ \
125 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
126 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN);
127
128 #define CALL7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
129 /* N##_type Ext_##N = NULL; */ \
130 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN) { \
131 static N##_type fun = NULL; \
132 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
133 return fun(AN, BN, CN, DN, EN, FN, GN); }
134 #define DECLARE7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
135 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
136 /* extern N##_type Ext_##N; */ \
137 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
138 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN);
139
140 #define CALL8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
141 /* N##_type Ext_##N = NULL; */ \
142 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN) { \
143 static N##_type fun = NULL; \
144 if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \
145 return fun(AN, BN, CN, DN, EN, FN, GN, HN); }
146 #define DECLARE8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
147 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
148 /* extern N##_type Ext_##N; */ \
149 V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
150 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN);
151
152
153 DECLARE1(void, solve_DELETE, solve_storage**, S)
154 DECLARE1(void, solve_NULL, solve_storage*, x)
155 DECLARE7(int, solvePosDef, double*, M, int, size, bool, posdef,
156 double *, rhs, int, rhs_cols, double *, logdet, solve_storage *, PT)
157 DECLARE8(int, solvePosDefResult, double*, M, int, size, bool, posdef,
158 double *, rhs, int, rhs_cols, double *, result, double*, logdet,
159 solve_storage*, PT)
160 DECLARE3(int, sqrtPosDef, double *, M, int, size, solve_storage *, pt)
161 DECLARE3(int, sqrtPosDefFree, double *, M, int, size, solve_storage *, pt)
162 DECLARE3(int, sqrtRHS, solve_storage *, pt, double*, RHS, double *, res)
163 DECLARE2(int, invertMatrix, double *, M, int, size)
164 DECLARE2(double, StruveH, double, x, double, nu)
165 DECLARE3(double, StruveL, double, x, double, nu, bool, expScaled)
166 DECLARE1(double, I0mL0, double, x)
167 DECLARE3(double, WM, double, x, double, nu, double, factor)
168 DECLARE3(double, DWM, double, x, double, nu, double, factor)
169 DECLARE3(double, DDWM, double, x, double, nu, double, factor)
170 DECLARE3(double, D3WM, double, x, double, nu, double, factor)
171 DECLARE3(double, D4WM, double, x, double, nu, double, factor)
172 DECLARE4(double, logWM, double, x, double, nu1, double, nu2, double, factor)
173 DECLARE1(double, Gauss, double, x)
174 DECLARE1(double, DGauss, double, x)
175 DECLARE1(double, DDGauss, double, x)
176 DECLARE1(double, D3Gauss, double, x)
177 DECLARE1(double, D4Gauss, double, x)
178 DECLARE1(double, logGauss, double, x)
179
180 DECLARE1(void, getErrorString, errorstring_type, errorstring)
181 DECLARE1(void, setErrorLoc, errorloc_type, errorloc)
182 DECLARE1(void, getUtilsParam, utilsparam **, up)
183 DECLARE7(void, attachRFoptions, const char **, prefixlist, int, N,
184 const char ***, all, int *, allN, setparameterfct, set,
185 finalsetparameterfct, final, getparameterfct, get)
186 DECLARE2(void, detachRFoptions, const char **, prefixlist, int, N)
187 DECLARE1(void, relaxUnknownRFoption, bool, relax)
188
189 DECLARE3(void, sorting, double*, data, int, len, usr_bool, NAlast)
190 DECLARE3(void, sortingInt, int*, data, int, len, usr_bool, NAlast)
191 DECLARE4(void, ordering, double*, data, int, len, int, dim, int *, pos)
192 DECLARE4(void, orderingInt, int*, data, int, len, int, dim, int *, pos)
193
194
195
196 /*
197
198 See in R package RandomFields, /src/userinterfaces.cc
199 CALL#(...)
200 at the beginning for how to make the functions available
201 in a calling package
202
203 */
204 #ifdef __cplusplus
205 }
206 #endif
207
208
209 #endif
210
211
0
1 #ifndef miraculix_initrinsics_H
2 #define miraculix_initrinsics_H 1
3
4 #include <inttypes.h> // uintptr_t
5
6 // PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -mavx ODER -march=native
7 #ifdef __MMX__
8 #define MMX __MMX__
9 #endif
10 #ifdef __SSE__
11 #define SSE __SSE__
12 #endif
13 #ifdef __SSE2__
14 #define SSE2 __SSE2__
15 #endif
16 #ifdef __SSE3__
17 #define SSE3 __SSE3__
18 #endif
19 #ifdef __SSSE3__
20 #define SSSE3 __SSSE3__
21 #endif
22 #ifdef __SSE4A__
23 #define SSE4A __SSE4A__
24 #endif
25 #if defined __SSE41__ || defined __SS42__
26 #define SSE412 1
27 #endif
28 //
29 #ifdef __AVX__
30 #define AVX 1
31 #endif
32 #ifdef __AVX2__
33 #define AVX2 1
34 #endif
35
36
37 #if defined (AVX512)
38 #define SSEBITS 512
39 #define SSEMODE 30
40 #elif defined (SSE)
41 #define SSEBITS 256
42 #define SSEMODE 20
43 #elif defined (SSE)
44 #define SSEBITS 128
45 #define SSEMODE 10
46 #else
47 #define SSEBITS 64
48 #define SSEMODE 0
49 #endif
50
51 #ifndef WIN32
52 // #define FMA_AVAILABLE __FMA__
53 #endif
54
55
56 #if __GNUC__ > 4 || \
57 (__GNUC__ == 4 && (__GNUC_MINOR__ > 9 || \
58 (__GNUC_MINOR__ == 9 && __GNUC_PATCHLEVEL__ >= 1)))
59 //#define OpenMP4 1
60 #endif
61
62
63 //#define ALIGNED __declspec(align(SSEBITS/8))
64
65
66 #ifdef MMX
67 //#include <mmintrin.h>
68 #endif
69
70 #ifdef SSE
71 #include <xmmintrin.h>
72 #endif
73
74 #ifdef SSE2
75 //#include <emmintrin.h>
76 #endif
77
78 #ifdef SSE3
79 //#include <pmmintrin.h>
80 #endif
81
82 #ifdef SSSE3
83 //#include <tmmintrin.h>
84 #endif
85
86 #ifdef SSE4A
87 //#include <ammintrin.h>
88 #endif
89
90 #ifdef SSE412
91 //#include <smmintrin.h>
92 #endif
93
94 #if defined AVX || defined AVX2
95 #include <x86intrin.h>
96 #endif
97
98 #ifdef AVX512
99 //#include <immintrin.h>
100 #endif
101
102
103
104
105 #if defined AVX
106 #define BytesPerBlock 32
107 #define UBlockType __m256i
108 #define BlockType __m256i ALIGNED
109 #define Double __m256d
110 #define MAXDOUBLE _mm256_max_pd
111 #define MAXINTEGER _mm256_max_epi32
112 #define LOAD _mm256_load_si256
113 // #define EXPDOUBLE mm256_exp_pd // only on intel compiler
114 #define ADDDOUBLE _mm256_add_pd
115 #define SUBDOUBLE _mm256_sub_pd
116 #define MULTDOUBLE _mm256_mul_pd
117 #define LOADuDOUBLE _mm256_loadu_pd
118 #define LOADDOUBLE _mm256_load_pd
119 #define STOREuDOUBLE _mm256_storeu_pd
120 #define ZERODOUBLE _mm256_setzero_pd()
121
122 #elif defined SSE2
123 #define BytesPerBlock 16
124 #define UBlockType __m128i
125 #define BlockType __m128i ALIGNED
126 #define Double __m128d
127 #define MAXDOUBLE _mm_max_pd
128 #define MAXINTEGER _mm_max_epi32
129 #define LOAD _mm_load_si128
130 // #define EXPDOUBLE _mm_exp_pd // only on intel compiler
131 #define ADDDOUBLE _mm_add_pd
132 #define SUBDOUBLE _mm_sub_pd
133 #define MULTDOUBLE _mm_mul_pd
134 #define LOADuDOUBLE _mm_loadu_pd
135 #define LOADDOUBLE _mm_load_pd
136 #define STOREuDOUBLE _mm_storeu_pd
137 #define ZERODOUBLE _mm_setzero_pd()
138
139 #else
140 #define BytesPerBlock 8
141 #endif
142
143 #define algn_general(X) ((1L + (uintptr_t) (((uintptr_t) X - 1L) / BytesPerBlock)) * BytesPerBlock)
144 double inline *algn(double *X) {assert(algn_general(X)>=(uintptr_t)X); return (double *) algn_general(X); }
145 int inline *algnInt(int *X) {assert(algn_general(X)>=(uintptr_t)X); return (int *) algn_general(X); }
146 #define ALIGNED __attribute__ ((aligned (BytesPerBlock)))
147 #define doubles (BytesPerBlock / 8)
148 #define integers (BytesPerBlock / 8)
149
150 #endif
151
152
11 Authors
22 Martin Schlather, schlather@math.uni-mannheim.de
33
4 Copyright (C) 2015 -- 2016 Martin Schlather, Reinhard Furrer
4 Copyright (C) 2015 -- 2017 Martin Schlather
55
66 This program is free software; you can redistribute it and/or
77 modify it under the terms of the GNU General Public License
1919 */
2020
2121 #include <R_ext/Lapack.h>
22 #include "General_utils.h"
23 #include "kleinkram.h"
22 //#include "def.h" // never change this line
23 #include "General_utils.h" //#include <General_utils.h>
24 #include "zzz_RandomFieldsUtils.h"
25
26
27 #define SCALAR(A,B,C) scalarX(A,B,C, SCALAR_AVX)
28 #define LINEAR(A,B,C,D) linearX(A,B,C,D,6)
29
2430
2531 void strcopyN(char *dest, const char *src, int n) {
2632 if (n > 1) {
3036 dest[n] = '\0';
3137 }
3238
33
34 double scalar(double *A, double *B, int N) {
35 double ANS;
36 SCALAR_PROD(A, B, N, ANS);
37 return ANS;
38 }
39
40
4139 void AtA(double *a, int nrow, int ncol, double *C) {
4240 // C = A^T %*% A
4341 #ifdef DO_PARALLEL
44 //#pragma omp parallel for num_threads(2) schedule(dynamic) if (MULTIMINSIZE(ncol))
45 #pragma omp parallel for schedule(dynamic) if (MULTIMINSIZE(ncol))
42 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(ncol)) schedule(dynamic, 20)
4643 #endif
4744 for (int i=0; i<ncol; i++) {
4845 double
4946 *A = a + i * nrow,
5047 *B = A;
5148 for (int j=i; j<ncol; j++, B+=nrow) {
52 C[i * ncol + j] = C[i + ncol * j] = scalar(A, B, nrow);
49 C[i * ncol + j] = C[i + ncol * j] = SCALAR(A, B, nrow);
5350 }
5451 }
5552 }
5653
54
55 void xA_noomp(double *x, double*A, int nrow, int ncol, double *y) {
56 if (A == NULL) {
57 if (nrow != ncol || nrow <= 0) BUG;
58 MEMCOPY(y, x, sizeof(double) * nrow);
59 } else {
60 for (int i=0; i<ncol; i++) {
61 y[i] = SCALAR(x, A + i * nrow, nrow);
62 }
63 }
64 }
5765
5866 void xA(double *x, double*A, int nrow, int ncol, double *y) {
5967 if (A == NULL) {
6068 if (nrow != ncol || nrow <= 0) BUG;
6169 MEMCOPY(y, x, sizeof(double) * nrow);
6270 } else {
63 for (int i=0; i<ncol; i++) {
64 y[i] = scalar(x, A + i * nrow, nrow);
65 }
66 }
67 }
68
69 void xA_omp(double *x, double*A, int nrow, int ncol, double *y) {
70 if (A == NULL) {
71 if (nrow != ncol || nrow <= 0) BUG;
72 MEMCOPY(y, x, sizeof(double) * nrow);
73 } else {
74 #ifdef DO_PARALLEL
75 #pragma omp parallel for if (MULTIMINSIZE(ncol) && MULTIMINSIZE(nrow))
71 #ifdef DO_PARALLEL
72 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(ncol) && MULTIMINSIZE(nrow))
7673 #endif
77 for (int i=0; i<ncol; i++) y[i] = scalar(x, A + i * nrow, nrow);
78 }
79 }
80
81
82 #define TWOSCALAR_PROD(A1, A2, B, N, ANS1, ANS2) { \
83 int k_ =0, \
84 end_ = N - 4; \
85 ANS1 = ANS2 = 0.0; \
86 for (; k_<end_; k_+=5) { \
87 ANS1 += A1[k_] * B[k_] \
88 + A1[k_ + 1] * B[k_ + 1] \
89 + A1[k_ + 2] * B[k_ + 2] \
90 + A1[k_ + 3] * B[k_ + 3]; \
91 ANS2 += A2[k_] * B[k_] \
92 + A2[k_ + 1] * B[k_ + 1] \
93 + A2[k_ + 2] * B[k_ + 2] \
94 + A2[k_ + 3] * B[k_ + 3]; \
95 } \
96 for (; k_<N; k_++) { \
97 ANS1 += A1[k_] * B[k_]; \
98 ANS2 += A2[k_] * B[k_]; \
99 } \
100 }
101
102
74 for (int i=0; i<ncol; i++) y[i] = SCALAR(x, A + i * nrow, nrow);
75 }
76 }
77
10378 void xA(double *x1, double *x2, double*A, int nrow, int ncol, double *y1,
10479 double *y2) {
10580 if (A == NULL) {
10782 MEMCOPY(y1, x1, sizeof(double) * nrow);
10883 MEMCOPY(y2, x2, sizeof(double) * nrow);
10984 } else {
110 #ifdef DO_PARALLEL
111 #pragma omp parallel for if (MULTIMINSIZE(ncol) && MULTIMINSIZE(nrow))
85 double *a = A;
86 for (int i=0; i<ncol; i++, a += nrow) {
87 y1[i] = SCALAR(x1, a, nrow);
88 y2[i] = SCALAR(x2, a, nrow);
89 }
90 }
91 }
92
93 void xAx(double *x, double*A, int nrow, double *y) {
94 double sum = 0.0;
95 #ifdef DO_PARALLEL
96 #pragma omp parallel for num_threads(CORES) reduction(+:sum) if (MULTIMINSIZE(nrow) && MULTIMINSIZE(nrow))
11297 #endif
113 for (int i=0; i<ncol; i++) {
114 double d1, d2,
115 *a = A + i*nrow;
116 TWOSCALAR_PROD(x1, x2, a, nrow, d1, d2);
117 y1[i] = d1;
118 y2[i] = d2;
119 }
120 }
121 }
122
98 for (int i=0; i<nrow; i++) sum += x[i] * SCALAR(x, A + i * nrow, nrow);
99 *y = sum;
100 }
123101
124102 void Ax(double *A, double*x, int nrow, int ncol, double *y) {
125103 if (A == NULL) {
127105 MEMCOPY(y, x, sizeof(double) * nrow);
128106 } else {
129107 #ifdef DO_PARALLEL
130 #pragma omp parallel for if (MULTIMINSIZE(ncol) && MULTIMINSIZE(nrow))
108 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(ncol) && MULTIMINSIZE(nrow))
131109 for (int j=0; j<nrow; j++) {
132110 double dummy = 0.0;
133111 int k = j;
177155 int size = nrow * dim;
178156
179157 #ifdef DO_PARALLEL
180 #pragma omp parallel for reduction(+:result)
158 #pragma omp parallel for num_threads(CORES) reduction(+:result)
181159 #endif
182160 for (int j=0; j<size; j+=nrow) {
183161 double scalar = 0.0;
194172 double
195173 *endpX = X + nrow,
196174 *dummy = (double*) MALLOC(sizeof(double) * size); // dummy = XC
197 if (dummy == NULL) ERR("XCXt: memory allocation error in XCXt");
175 if (dummy == NULL) RFERROR("XCXt: memory allocation error in XCXt");
198176
199177 #ifdef DO_PARALLEL
200 #pragma omp parallel for
178 #pragma omp parallel for num_threads(CORES)
201179 #endif
202180 for (double *pX = X; pX < endpX; pX++) {
203181 double *pdummy = dummy + (pX - X);
212190
213191 // V = dummy X^t
214192 #ifdef DO_PARALLEL
215 #pragma omp parallel for
193 #pragma omp parallel for num_threads(CORES)
216194 #endif
217195 for (int rv=0; rv<nrow; rv++) {
218196 for (int cv=rv; cv<nrow; cv++) {
233211 double xVy = 0.0;
234212 int dimM1 = dim - 1;
235213 #ifdef DO_PARALLEL
236 #pragma omp parallel for reduction(+:xVy) if (MULTIMINSIZE(dim))
214 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(dim)) reduction(+:xVy)
237215 #endif
238216 for (int d=0; d<dim; d++) {
239217 int i,
252230 assert(z != NULL);
253231 int dimM1 = dim - 1;
254232 #ifdef DO_PARALLEL
255 #pragma omp parallel for if (MULTIMINSIZE(dim))
233 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(dim))
256234 #endif
257235 for (int d=0; d<dim; d++) {
258236 double dummy;
272250 double xVx = 0.0;
273251 int dimM1 = dim - 1;
274252 #ifdef DO_PARALLEL
275 #pragma omp parallel for reduction(+:xVx)
253 #pragma omp parallel for num_threads(CORES) reduction(+:xVx)
276254 #endif
277255 for (int d=0; d<dim; d++) {
278256 int i,
295273 double xVx = 0.0;
296274 int dimM1 = dim - 1;
297275 #ifdef DO_PARALLEL
298 #pragma omp parallel for reduction(+:xVx)
276 #pragma omp parallel for num_threads(CORES) reduction(+:xVx)
299277 #endif
300278 for (int d=0; d<dim; d++) {
301279 int i,
313291 void matmult(double *a, double *b, double *c, int l, int m, int n) {
314292 // multiplying an lxm- and an mxn-matrix, saving result in C
315293 #ifdef DO_PARALLEL
316 #pragma omp parallel for
294 #pragma omp parallel for num_threads(CORES)
317295 #endif
318296 for (int i=0; i<l; i++) {
319297 double *A = a + i,
332310 // multiplying t(A) and B with dim(A)=(m,l) and dim(B)=(m,n),
333311 // saving result in C
334312 #ifdef DO_PARALLEL
335 #pragma omp parallel for
313 #pragma omp parallel for num_threads(CORES)
336314 #endif
337315 for (int i=0; i<l; i++) {
338316 double *C = c + i,
339317 *Aim = A + i * m;
340 for (int j=0; j<n; j++) C[j * l] = scalar(Aim, B + j * m, m);
341 }
342 }
343
344
345
346 void matmult_2ndtransp(double *a, double *B, double *c, int m, int l, int n) {
347 // multiplying A and t(B) with dim(A)=(m,l) and dim(B)=(n, l),
318 for (int j=0; j<n; j++) C[j * l] = SCALAR(Aim, B + j * m, m);
319 }
320 }
321
322
323
324 void matmult_2ndtransp(double *a, double *B, double *c, int l, int m, int n) {
325 // multiplying A and t(B) with dim(A)=(l, m) and dim(B)=(n, m),
348326 // saving result in C
349327 int msq = m * m;
350328 #ifdef DO_PARALLEL
351 #pragma omp parallel for
329 #pragma omp parallel for num_threads(CORES) if (l * m * n > 1000)
352330 #endif
353331 for (int i=0; i<l; i++) {
354332 double *C = c + i,
368346 // calculating t(A B) with dim(A)=(m,l) and dim(B)=(m,n),
369347 // saving result in C
370348 #ifdef DO_PARALLEL
371 #pragma omp parallel for
349 #pragma omp parallel for num_threads(CORES)
372350 #endif
373351 for (int i=0; i<l; i++) {
374352 double *A = a + i,
387365 void Xmatmult(double *A, double *B, double *C, int l, int m, int n) {
388366 // multiplying an lxm- and an mxn-matrix, saving result in C
389367 #ifdef DO_PARALLEL
390 #pragma omp parallel for
368 #pragma omp parallel for num_threads(CORES)
391369 #endif
392370 for (int i=0; i<l; i++) {
393371 for (int jl=i, jm=0, j=0; j<n; j++, jl+=l, jm+=m) {
403381 // multiplying t(A) and B with dim(A)=(m,l) and dim(B)=(m,n),
404382 // saving result in C
405383 #ifdef DO_PARALLEL
406 #pragma omp parallel for
384 #pragma omp parallel for num_threads(CORES)
407385 #endif
408386 for (int i=0; i<l; i++) {
409387 int im = i * m;
574552 }
575553
576554
555 SEXP MatString(char **V, int row, int col, int max) {
556 if (V==NULL) return allocMatrix(STRSXP, 0, 0);
557 int n = row * col;
558 if (n>max) {
559 int nn[2];
560 nn[0] = row;
561 nn[1] = col;
562 return TooLarge(nn, 2);
563 }
564 SEXP dummy;
565 PROTECT(dummy=allocMatrix(STRSXP, row, col));
566 for (int k=0; k<n; k++)
567 SET_STRING_ELT(dummy, k, mkChar(V[k]));
568 UNPROTECT(1);
569 return dummy;
570 }
571
572 SEXP MatString(char** V, int row, int col) {
573 return MatString(V, row, col, MAXINT);
574 }
575
577576 SEXP MatInt(int* V, int row, int col, int max) {
578577 if (V==NULL) return allocMatrix(INTSXP, 0, 0);
579578 int n = row * col;
624623
625624
626625
627 //static int ZZ = 0;
626 usr_bool UsrBoolRelaxed(SEXP p, char *name, int idx) {
627 double dummy = Real(p, name, idx);
628 if (!R_finite(dummy)) return Nan;
629 return dummy==0.0 ? False : True ;
630 }
631
632
628633 usr_bool UsrBool(SEXP p, char *name, int idx) {
629634 double dummy = Real(p, name, idx);
630635 if (dummy == 0.0) return False;
631636 else if (dummy == 1.0) return True;
632 else if (ISNA(dummy) || ISNAN(dummy)) return Nan;
633 ERR("invalid value for boolean variable");
637 else if (ISNAN(dummy)) return Nan;
638 RFERROR2("invalid value (%d) for boolean variable '%.50s'.", (int) dummy, name);
634639 }
635640
636641
646651
647652 SEXP String(char V[][MAXCHAR], int n, int max) {
648653 SEXP str;
649 if (V==NULL) return allocVector(VECSXP, 0);
654 if (V==NULL) return allocVector(STRSXP, 0);
650655 if (n>max) return TooLarge(&n, 1);
651656 if (n<0) return TooSmall();
652657 PROTECT(str = allocVector(STRSXP, n));
660665
661666 SEXP String(int *V, const char * List[], int n, int endvalue) {
662667 SEXP str;
663 if (V==NULL || n <= 0) return allocVector(VECSXP, 0);
668 if (V==NULL || n <= 0) return allocVector(STRSXP, 0);
664669 int k;
665670 for (k=0; k<n; k++) {
666671 if (V[k] == endvalue) break;
667672 }
673 // printf("k=%d, n=%d\n", k, n);
668674 PROTECT(str = allocVector(STRSXP, k));
669675 for (int i=0; i<k; i++) {
676 // printf("V[%d]=%d\n", i, V[i]);
677 // printf("%.50s\n", List[V[i]]);
670678 SET_STRING_ELT(str, i, mkChar(List[V[i]]));
671679 }
672680 UNPROTECT(1);
673681 return str;
674682 }
675683
676 //static int ZZ = 0;
677684 double Real(SEXP p, char *name, int idx) {
678 // if(++ZZ==65724){printf("type=%d %d '%s'\n",ZZ,TYPEOF(p), CHAR(STRING_ELT(p,0)));cov_model *cov;crash(cov);}
685 // {printf("%.50s type=%d \n", name,TYPEOF(p));}
679686 if (p != R_NilValue) {
680687 assert(idx < length(p));
681688 switch (TYPEOF(p)) {
682689 case REALSXP : return REAL(p)[idx];
683 case INTSXP : return INTEGER(p)[idx]==NA_INTEGER
684 ? RF_NA : (double) INTEGER(p)[idx];
685 case LGLSXP : return LOGICAL(p)[idx]==NA_LOGICAL ? RF_NA
686 : (double) LOGICAL(p)[idx];
690 case INTSXP :
691 if (INTEGER(p)[idx]==NA_INTEGER) return RF_NA;
692 else return((double) INTEGER(p)[idx]);
693 case LGLSXP :
694 if (LOGICAL(p)[idx]==NA_LOGICAL) return(RF_NA);
695 else return((double) LOGICAL(p)[idx]);
687696 default : {}
688697 }
689698 }
690 ERR2("'%s' cannot be transformed to double! (type=%d)\n", name, TYPEOF(p));
699
700 RFERROR2("'%.50s' can not be transformed to double! (type=%d)\n", name, TYPEOF(p));
691701 return RF_NA; // to avoid warning from compiler
692702 }
693703
695705
696706 void Real(SEXP el, char *name, double *vec, int maxn) {
697707 if (el == R_NilValue) {
698 ERR1("'%s' cannot be transformed to double.\n", name);
708 RFERROR1("'%.50s' cannot be transformed to double.\n", name);
699709 }
700710 int n = length(el);
701711 for (int j=0, i=0; i<maxn; i++) {
718728 if (ISNAN(value)) {
719729 return NA_INTEGER;
720730 }
721 if (value == TRUNC(value)) return (int) value;
731 int intvalue;
732 intvalue = (int) value;
733 // print("%10g %d %10e\n ", value, intvalue, value-intvalue);
734 if (value == intvalue) return intvalue;
722735 else {
723 ERR2("%s: integer value expected. Got %e.", name, value);
736 RFERROR2("%.50s: integer value expected. Got %10e.", name, value);
724737 }
725738 case LGLSXP :
726 return LOGICAL(p)[idx]==NA_LOGICAL ? NA_INTEGER : (int) LOGICAL(p)[idx];
739 if (LOGICAL(p)[idx]==NA_LOGICAL) return(NA_INTEGER);
740 else return((int) LOGICAL(p)[idx]);
727741 default : {}
728742 }
729743 } else if (nulltoNA) return NA_INTEGER;
730 ERR2("%s: unmatched type of parameter [type=%d]", name, TYPEOF(p));
744 RFERROR2("%.50s: unmatched type of parameter [type=%d]", name, TYPEOF(p));
731745 return NA_INTEGER; // compiler warning vermeiden
732746 }
733747
738752
739753 void Integer(SEXP el, char *name, int *vec, int maxn) {
740754 if (el == R_NilValue) {
741 ERR1("'%s' cannot be transformed to integer.\n",name);
755 RFERROR1("'%.50s' cannot be transformed to integer.\n",name);
742756 }
743757 int n = length(el);
744758 for (int j=0, i=0; i<maxn; i++) {
753767 void Integer2(SEXP el, char *name, int *vec) {
754768 int n;
755769 if (el == R_NilValue || (n = length(el))==0) {
756 ERR1("'%s' cannot be transformed to integer.\n",name);
770 RFERROR1("'%.50s' cannot be transformed to integer.\n",name);
757771 }
758772
759773 vec[0] = Integer(el, name, 0);
774 if (vec[0] == NA_INTEGER || vec[0] < 1)
775 RFERROR1("first component of '%.50s' must be at least 1", name);
760776 if (n==1) vec[1] = vec[0];
761777 else {
762 vec[1] = Integer(el, name, n-1);
778 vec[1] = Integer(el, name, n-1);
779 if ( vec[1] != NA_INTEGER && vec[1] < vec[0])
780 RFERROR1("'%.50s' must be increasing", name);
763781 if (n > 2) {
764782 int v = vec[0] + 1;
765783 for (int i = 1; i<n; i++, v++)
766 if (Integer(el, name, i) != v) ERR("not a sequence of numbers");
784 if (Integer(el, name, i) != v)
785 RFERROR1("'%.50s' is not a sequence of numbers",name);
786
767787 }
768788 }
769789 }
776796 if (p != R_NilValue)
777797 assert(idx < length(p));
778798 switch (TYPEOF(p)) {
779 case REALSXP: return ISNAN(REAL(p)[idx]) ? NA_LOGICAL : (bool) REAL(p)[idx];
799 case REALSXP:
800 if (ISNAN(REAL(p)[idx])) return NA_LOGICAL ;
801 else return (bool) REAL(p)[idx];
780802 case INTSXP :
781 return INTEGER(p)[idx]==NA_INTEGER ? NA_LOGICAL : (bool) INTEGER(p)[idx];
803 if (INTEGER(p)[idx]==NA_INTEGER) return NA_LOGICAL;
804 else return (bool) INTEGER(p)[idx];
782805 case LGLSXP : return LOGICAL(p)[idx];
783806 default : {}
784807 }
785 ERR1("'%s' cannot be transformed to logical.\n", name);
808 RFERROR1("'%.50s' cannot be transformed to logical.\n", name);
786809 return NA_LOGICAL; // to avoid warning from compiler
787810 }
788811
794817 if (type == CHARSXP) return CHAR(el)[0];
795818 if (type == STRSXP) {
796819 if (length(el)==1) {
797 if (strlen(CHAR(STRING_ELT(el,0))) == 1)
820 if (STRLEN(CHAR(STRING_ELT(el,0))) == 1)
798821 return (CHAR(STRING_ELT(el,0)))[0];
799 else if (strlen(CHAR(STRING_ELT(el,0))) == 0)
822 else if (STRLEN(CHAR(STRING_ELT(el,0))) == 0)
800823 return '\0';
801824 }
802825 }
803826
804827 ErrorHandling:
805 ERR1("'%s' cannot be transformed to character.\n", name);
828 RFERROR1("'%.50s' cannot be transformed to character.\n", name);
806829 return 0; // to avoid warning from compiler
807830 }
808831
809832
810833 void String(SEXP el, char *name, char names[][MAXCHAR], int maxlen) {
811834 int l = length(el);
812 char msg[200];
813835 SEXPTYPE type;
814836 if (el == R_NilValue) goto ErrorHandling;
815837 if (l > maxlen) {
816 ERR1("number of variable names exceeds %d. Take abbreviations?", maxlen);
838 RFERROR1("number of variable names exceeds %d. Take abbreviations?", maxlen);
817839 }
818840 type = TYPEOF(el);
819841 // printf("type=%d %d %d %d\n", TYPEOF(el), INTSXP, REALSXP, LGLSXP);
831853 return;
832854
833855 ErrorHandling:
834 SPRINTF(msg, "'%s' cannot be transformed to character.\n", name);
835 ERR(msg);
856 RFERROR1("'%.50s' cannot be transformed to character.\n", name);
836857 }
837858
838859
842863 num = INT;
843864 if (num<0) {
844865 num=0;
845 WARN1("'%s' which has been negative is set 0.\n",name);
866 WARN1("'%.50s', which has been negative, is set 0.\n",name);
846867 }
847868 return num;
848869 }
852873 num = NUM;
853874 if (num<0.0) {
854875 num=0.0;
855 WARN1("%s which has been negative is set 0.\n",name);
876 WARN1("%.50s, which has been negative, is set 0.\n",name);
856877 }
857878 return num;
858879 }
862883 num = NUM;
863884 if (num>0.0) {
864885 num=0.0;
865 WARN1("%s which has been positive is set 0.\n",name);
886 WARN1("%.50s, which has been positive, is set 0.\n",name);
866887 }
867888 return num;
868889 }
871892 int num;
872893 num = INT;
873894 if (num<=0) {
874 num=0;
875 WARN1("'%s' which has been negative is set 0.\n",name);
895 WARN2("'%.50s', which has been %.50s, is set 1.\n",
896 name, num==0L ? "0" : "negative");
897 num=1L;
876898 }
877899 return num;
878900 }
881903 double num;
882904 num = NUM;
883905 if (num<=0.0) {
884 num=0.0;
885 WARN1("%s which has been negative is set 0.\n",name);
906 WARN2("'%.50s', which has been %.50s, is set 1.\n",
907 name, num==0.0 ? "0" : "negative");
908 num=1.0;
886909 }
887910 return num;
888911 }
891914
892915 SEXP ExtendedInteger(double x) {
893916 return ScalarInteger(R_FINITE(x) ? x : NA_INTEGER);
894 }
895
896 SEXP ExtendedBoolean(double x) {
897 return ScalarLogical(ISNAN(x) ? NA_LOGICAL : x != 0.0);
898917 }
899918
900919 SEXP ExtendedBooleanUsr(usr_bool x) {
908927 unsigned int ln;
909928 int Nr;
910929 Nr=0;
911 ln=strlen(name);
912 // print("Match %d %d %s %s %d\n", Nr, n, name, List[Nr], ln);
913
914 while ( Nr < n && strncmp(name, List[Nr], ln)) {
930 ln=STRLEN(name);
931 // print("Match %d %d %.50s %.50s %d\n", Nr, n, name, List[Nr], ln);
932
933 while ( Nr < n && STRNCMP(name, List[Nr], ln)) {
915934 Nr++;
916935 }
917936 if (Nr < n) {
918 if (ln==strlen(List[Nr])) // exactmatching -- take first -- changed 1/7/07
937 if (ln==STRLEN(List[Nr])) // exactmatching -- take first -- changed 1/7/07
919938 return Nr;
920939 // a matching function is found. Are there other functions that match?
921940 int j;
923942 j=Nr+1; // if two or more covariance functions have the same name
924943 // the last one is taken
925944 while (j<n) {
926 while ( (j<n) && strncmp(name, List[j], ln)) {j++;}
945 while ( (j<n) && STRNCMP(name, List[j], ln)) {j++;}
927946 if (j<n) {
928 if (ln==strlen(List[j])) { // exactmatching -- take first
947 if (ln==STRLEN(List[j])) { // exactmatching -- take first
929948 return j;
930949 }
931950 else {multiplematching=true;}
944963 unsigned int ln;
945964 int Nr;
946965 Nr=0;
947 ln=strlen(name);
948 // print("Matchx %d %d %s %s %d\n", Nr, n, name, List[Nr], ln);
949
950 while ( Nr < n && strncmp(name, List[Nr], ln)) {
951 // print(" %d %d %s %s %d\n", Nr, n, name, List[Nr], ln);
952 // printf("%s\n", List[Nr]);
966 ln=STRLEN(name);
967 // print("Matchx %d %d %.50s %.50s %d\n", Nr, n, name, List[Nr], ln);
968
969 while ( Nr < n && STRNCMP(name, List[Nr], ln)) {
970 // print(" %d %d %.50s %.50s %d\n", Nr, n, name, List[Nr], ln);
971 // printf("%.50s\n", List[Nr]);
953972 Nr++;
954973 }
955974 if (Nr < n) {
956 if (ln==strlen(List[Nr])) {// exactmatching -- take first -- changed 1/7/07
957 // print(" found X %d %d %s %s %d\n", Nr, n, name, List[Nr], ln);
975 if (ln==STRLEN(List[Nr])) {// exactmatching -- take first -- changed 1/7/07
976 // print(" found X %d %d %.50s %.50s %d\n", Nr, n, name, List[Nr], ln);
958977 return Nr;
959978 }
960979 // a matching function is found. Are there other functions that match?
963982 j=Nr+1; // if two or more covariance functions have the same name
964983 // the last one is taken
965984 while (j<n) {
966 while ( (j<n) && strncmp(name, List[j], ln)) {j++;}
985 while ( (j<n) && STRNCMP(name, List[j], ln)) {j++;}
967986 if (j<n) {
968 if (ln==strlen(List[j])) { // exactmatching -- take first
987 if (ln==STRLEN(List[j])) { // exactmatching -- take first
969988 return j;
970989 }
971990 else {multiplematching=true;}
975994 if (multiplematching) {return MULTIPLEMATCHING;}
976995 } else return NOMATCHING;
977996
978 // print(" found %d %d %s %s %d\n", Nr, n, name, List[Nr], ln);
997 // print(" found %d %d %.50s %.50s %d\n", Nr, n, name, List[Nr], ln);
979998
980999 return Nr;
9811000 }
9911010
9921011 if (TYPEOF(el) == NILSXP) goto ErrorHandling;
9931012 if (len_el > maxlen_ans)
994 ERR2("option '%s' is too long. Maximum length is %d.", name, maxlen_ans);
1013 RFERROR2("option '%.50s' is too long. Maximum length is %d.", name, maxlen_ans);
9951014
9961015 if (TYPEOF(el) == STRSXP) {
9971016 for (k=0; k<len_el; k++) {
10091028 }
10101029
10111030 ErrorHandling0:
1012 SPRINTF(dummy, "'%s': unknown value '%s'. Possible values are:",
1031 SPRINTF(dummy, "'%.50s': unknown value '%.50s'. Possible values are:",
10131032 name, CHAR(STRING_ELT(el, k)));
10141033 int i;
10151034 for (i=0; i<n-1; i++) {
1016 char msg[1000];
1017 SPRINTF(msg, "%s '%s',", dummy, List[i]);
1018 strcpy(dummy, msg);
1019 }
1020 ERR2("%s and '%s'.", dummy, List[i]);
1035 char info[1000];
1036 SPRINTF(info, "%.50s '%.50s',", dummy, List[i]);
1037 STRCPY(dummy, info);
1038 }
1039 RFERROR2("%.50s and '%.50s'.", dummy, List[i]);
10211040
10221041 ErrorHandling:
10231042 if (defaultvalue >= 0) {
10261045 return;
10271046 }
10281047
1029 ERR1("'%s': no value given.", name);
1048 RFERROR1("'%.50s': no value given.", name);
10301049 }
10311050
10321051 int GetName(SEXP el, char *name, const char * List[], int n,
10421061 }
10431062
10441063
1064 double ownround(double x) { return TRUNC((x + SIGN(x) * 0.5)); }
1065
1066
1067 double lonmod(double x, double modulus) {
1068 double
1069 halfmodulus = 0.5 * modulus,
1070 y = x + modulus + halfmodulus;
1071 return Mod(y, modulus) - halfmodulus;
1072 }
10451073
10461074 /*
10471075
10581086 x = 1.0 / x;
10591087 }
10601088 while (p != 0) {
1061 // printf(" ... %e %d : %e\n" , x, p, res);
1089 // printf(" ... %10e %d : %10e\n" , x, p, res);
10621090 if (p % 2 == 1) res *= x;
10631091 x *= x;
10641092 p /= 2;
10981126 dim = Dim[0];
10991127 end = v + Dim[1] * dim;
11001128
1101 // print("%d %d %f %f\n", dim , Dim[0], v, end);
1129 // print("%d %d %10g %10g\n", dim , Dim[0], v, end);
11021130
11031131 for (dr=0, v1=v; v1<end; v1+=dim) { // loop is one to large??
11041132 v2 = v1;
11121140 }
11131141 }
11141142 }
1115
1116
1117 int is_positive_definite(double *C, int dim) {
1118 int err,
1119 bytes = sizeof(double) * dim * dim;
1120 double *test;
1121 test = (double*) MALLOC(bytes);
1122 MEMCOPY(test, C, bytes);
1123 F77_CALL(dpofa)(test, &dim, &dim, &err);
1124 FREE(test);
1125 return(err == 0);
1126 }
11271143
11281144
11291145 int addressbits(void VARIABLE_IS_NOT_USED *addr) {
55 Martin Schlather, schlather@math.uni-mannheim.de
66
77
8 Copyright (C) 2015 Martin Schlather
8 Copyright (C) 2015 -- 2017 Martin Schlather
99
1010 This program is free software; you can redistribute it and/or
1111 modify it under the terms of the GNU General Public License
2727 #ifndef kleinkram_rfutils_h
2828 #define kleinkram_rfutils_h 1
2929
30 #include "Basic_utils.h"
31
30 #include <R.h>
31 #include <Rinternals.h>
32 #include "Basic_utils.h" //#include <Basic_utils.h>
3233
3334 typedef char name_type[][MAXCHAR];
3435
3536 void strcopyN(char *dest, const char *src, int n);
3637
3738 usr_bool UsrBool(SEXP p, char *name, int idx);
39 usr_bool UsrBoolRelaxed(SEXP p, char *name, int idx);
3840
3941 #define INT Integer(el, name, 0)
40 #define LOG Logical(el, name, 0)
42 #define LOGI Logical(el, name, 0)
4143 #define NUM Real(el, name, 0)
4244 #define USRLOG UsrBool(el, name, 0)
45 #define USRLOGRELAXED UsrBoolRelaxed(el, name, 0)
4346 #define CHR Char(el, name)
4447 #define STR(X, N) strcopyN(X, CHAR(STRING_ELT(el, 0)), N);
4548 #define POS0INT NonNegInteger(el, name) /* better: non-negative */
5760 SEXP Mat(double* V, int row, int col, int max);
5861 SEXP Mat_t(double* V, int row, int col, int max);
5962 SEXP MatInt(int* V, int row, int col, int max) ;
63 SEXP MatString(char **V, int row, int col, int max);
6064 SEXP Array3D(int** V, int depth, int row, int col, int max) ;
6165 SEXP String(char *V);
6266
6771 SEXP Mat(double* V, int row, int col);
6872 SEXP Mat_t(double* V, int row, int col);
6973 SEXP MatInt(int* V, int row, int col) ;
74 SEXP MatString(char** V, int row, int col);
7075 SEXP Array3D(int** V, int depth, int row, int col) ;
7176 SEXP String(char V[][MAXCHAR], int n, int max);
7277 SEXP String(int *V, const char * List[], int n, int endvalue);
102107
103108
104109 SEXP ExtendedInteger(double x);
105 SEXP ExtendedBoolean(double x);
106110 SEXP ExtendedBooleanUsr(usr_bool x);
107111
108112
111115 void XCXt(double *X, double *C, double *V, int nrow, int dim);
112116 void AtA(double *a, int nrow, int ncol, double *A);
113117 void xA(double *x, double*A, int nrow, int ncol, double *y);
118 void xA_noomp(double *x, double*A, int nrow, int ncol, double *y);
114119 void xA(double *x1, double *x2, double*A, int nrow, int ncol, double *y1,
115120 double *y2);
121 void xAx(double *x, double*A, int nrow, double *y);
116122 void Ax(double *A, double*x, int nrow, int ncol, double *y);
117123 void Ax(double *A, double*x1, double*x2, int nrow, int ncol, double *y1,
118124 double *y2);
124130 void matmulttransposed(double *A, double *B, double *C, int m, int l, int n);
125131 void matmult_2ndtransp(double *A, double *B, double *C, int m, int l, int n);
126132 void matmult_tt(double *A, double *B, double *C, int m, int l, int n);
127 double * matrixmult(double *m1, double *m2, int dim1, int dim2, int dim3);
133 double *matrixmult(double *m1, double *m2, int dim1, int dim2, int dim3);
128134
129135
130136
156162 }
157163
158164 double scalar(double *A, double *B, int N);
165 double ownround(double x);
159166
167 #define Mod(ZZ, modulus) ((ZZ) - FLOOR((ZZ) / (modulus)) * (modulus))
168 double lonmod(double x, double modulus);
160169
161170 /*
162171 extern "C" void vectordist(double *v, int *dim, double *dist, int *diag);
163172 bool is_diag(double *aniso, int dim);
164 */
173 */
165174
166175 #endif
0
1 /*
2 Authors
3 Martin Schlather, schlather@math.uni-mannheim.de
4
5 Collection of system specific auxiliary functions
6
7 Copyright (C) 2001 -- 2017 Martin Schlather,
8
9 This program is free software; you can redistribute it and/or
10 modify it under the terms of the GNU General Public License
11 as published by the Free Software Foundation; either version 3
12 of the License, or (at your option) any later version.
13
14 This program is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURSE. See the
17 GNU General Public License for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with this program; if not, write to the Free Software
21 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
22 */
23
24 /*
25
26 Makefile must be:
27
28 PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) -march=native -mssse3
29 PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -march=native -mssse3
30
31 */
32
33
34
35 #define BUG assert(false);
36
37 #include <assert.h>
38 #include "kleinkram.h"
39 #include "linear.h"
40 #include "intrinsics.h"
41 #include "Basic_utils.h"
42 #include "errors_messages.h"
43
44 #define Nlinmodi 9
45 name_type linmodi = { "1x1", "2x2", "4x4", "8x8", "near", "simple", "precise",
46 "kahan", "1x1p"};
47
48
49 typedef unsigned int uint32;
50
51
52 #define size 8
53 #define vectorlen (256 / (size * 8))
54 #define repet 8
55 #define atonce (vectorlen * repet)
56 #define VECTOR _mm256_loadu_pd
57 #define SET_0(NR) sum##NR = _mm256_setzero_pd()
58 #define P_0(NR) prod##NR = _mm256_setzero_pd()
59 #define SUMUP(NR, nr) sum##NR = _mm256_add_pd(sum##NR, sum##nr)
60 #define ADDF(NR) \
61 sum##NR = _mm256_fmadd_pd(VECTOR(x + i + NR * vectorlen),\
62 VECTOR(y + i + NR * vectorlen), sum##NR)
63 #define ADDN(NR) \
64 prod##NR = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \
65 VECTOR(y + i + NR * vectorlen)); \
66 sum##NR = _mm256_add_pd(sum##NR, prod##NR)
67
68
69 #if (7 != repet - 1)
70 wrong repet length
71 #endif
72 #if (3 != vectorlen - 1)
73 wrong vector length
74 #endif
75
76
77 #ifdef AVX
78 /*
79 void avx_linearprodDnearfma(double * x, double y, int len) {
80 // deutlich genauer zum 0 tarif
81 int i = 0,
82 lenM = len - (atonce - 1);
83 __m256d SET_0(0), SET_0(1), SET_0(2), SET_0(3), SET_0(4), SET_0(5), SET_0(6),SET_0(7),
84 P_0(0), P_0(1), P_0(2), P_0(3), P_0(4), P_0(5), P_0(6),P_0(7);
85
86 double *D = (double *) &sum0;
87
88 if ( len >= atonce) {
89 for (; i < lenM; i += atonce) {
90 //
91 ADDN(0); ADDN(1); ADDN(2); ADDN(3); ADDN(4); ADDN(5); ADDN(6); ADDN(7);
92 }
93 SUMUP(0, 1); SUMUP(2, 3); SUMUP(4, 5); SUMUP(6, 7);
94 SUMUP(0, 2); SUMUP(4, 6); SUMUP(0, 4);
95 }
96 lenM = len - vectorlen + 1;
97 for (; i < lenM; i += vectorlen) {
98 ADDN(0);
99 }
100
101 double sum = D[0] + D[1] + D[2] + D[3];
102
103 for (; i < len; i++) sum += x[i] * y[i];
104 }
105
106 */
107
108 #define MUL(NR) \
109 _mm256_storeu_pd(inout + i + NR * vectorlen, \
110 _mm256_add_pd(VECTOR(inout + i + NR * vectorlen), \
111 _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \
112 y)))
113
114 void avx_linearprodD(double * x, double Y, int len, double *inout) {
115 int i = 0,
116 lenM = len - (atonce - 1);
117 __m256d y = _mm256_set1_pd(Y);
118
119 for (; i < lenM; i += atonce) {
120 MUL(0); MUL(1); MUL(2); MUL(3); MUL(4); MUL(5); MUL(6); MUL(7);
121 // for (int k=0; k<atonce; k++) printf("k=%d %10g %10g %10g\n", i+k, inout[i+k], Y, x[i+k]);
122 }
123
124
125 lenM = len - vectorlen + 1;
126 for (; i < lenM; i += vectorlen) {
127 MUL(0);
128 }
129
130 for (; i < len; i++) inout[i] += x[i] * Y;
131 }
132
133
134 /*
135
136 void avx_linearprodDparallel(double * x, double y, int len) {
137 int i = 0,
138 lenM = len - (atonce - 1);
139 __m256d SET_0(0), P_0(0);
140 //zero =_mm256_setzero_pd();
141 double *D = (double *) &sum0;
142
143
144 if ( len >= atonce) {
145 #ifdef DO_PARALLEL
146 #pragma omp declare reduction(addpd: __m256d: \
147 omp_out = _mm256_add_pd(omp_out, omp_in)) \
148 initializer (omp_priv = _mm256_setzero_pd())
149 #endif
150 #ifdef DO_PARALLEL
151 #pragma omp parallel for num_threads(CORES) reduction(addpd:sum0)
152 #endif
153 for (i=0; i < lenM; i += atonce) {
154 //
155 ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); ADD(6); ADD(7);
156 }
157 }
158
159 lenM = len - vectorlen + 1;
160 for (; i < lenM; i += vectorlen) {
161 ADD(0);
162 }
163
164 double sum = D[0] + D[1] + D[2] + D[3];
165
166 for (; i < len; i++) sum += x[i] * y[i];
167 }
168
169
170 void avx_linearprodDP(double * x, double y, int len) {
171 int i = 0,
172 lenM = len - (atonce - 1);
173 __m256d SET_0(0), SET_0(1), P_0(0);
174 double *D = (double *) &sum1;
175
176 if ( len >= atonce) {
177
178 for (; i < lenM; ) {
179 int lenMM = i + vectorlen * (repet * 10 + 1);
180 if (lenMM > lenM) lenMM = lenM;
181 sum0 = _mm256_mul_pd(VECTOR(x + i), VECTOR(y + i));
182 i += vectorlen;
183 for (; i < lenMM; i += atonce) {
184 ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); ADD(6); ADD(7);
185 }
186 sum1 = _mm256_add_pd(sum0, sum1);
187 }
188 }
189
190 lenM = len - vectorlen + 1;
191 for (; i < lenM; i += vectorlen) {
192 prod0 = _mm256_mul_pd(VECTOR(x + i), VECTOR(y + i));
193 sum1 = _mm256_add_pd(sum1, prod0);
194 }
195
196 double sum = D[0] + D[1] + D[2] + D[3];
197
198 for (; i < len; i++) {
199 // printf("final %d\n", i);
200 sum += x[i] * y[i];
201 }
202 }
203
204
205
206
207 #define ADDK(NR) \
208 prod0 = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \
209 VECTOR(y + i + NR * vectorlen)); \
210 sum2 = _mm256_sub_pd(prod0, sum1);\
211 sum3 = _mm256_add_pd(sum0, sum2); \
212 sum1 = _mm256_sub_pd(sum3, sum0); \
213 sum0 = sum3; \
214 sum1 = _mm256_sub_pd(sum1, sum2);
215 void avx_linearprodDK(double * x, double y, int len) {
216 // Kahan enhanced
217 int i = 0,
218 lenM = len - (atonce - 1);
219 __m256d SET_0(0), // sum
220 SET_0(1), // c
221 SET_0(2), // y
222 SET_0(3), // t
223 P_0(0),
224 P_0(1);
225 double *D = (double *) &sum0;
226
227 if ( len >= atonce) {
228 for (; i < lenM; i += atonce) {
229 ADDK(0); ADDK(1); ADDK(2); ADDK(3); ADDK(4); ADDK(5); ADDK(6); ADDK(7);
230 }
231 }
232 lenM = len - vectorlen + 1;
233 for (; i < lenM; i += vectorlen) {
234 ADDK(0);
235 }
236 sum0 = _mm256_add_pd(sum0, prod1);
237
238 double sum = D[0] + D[1] + D[2] + D[3];
239
240 for (; i < len; i++) sum += x[i] * y[i];
241 }
242
243 */
244
245 #endif
246
247 /*
248 void linearprod( double * v1, double v2, int N){
249 double *endv1 = v1 + N,
250 sum = 0;
251 for(; v1!= endv1; v1++) sum+= v2 * v1[0];
252 }
253
254
255
256 void linearprodP( double * v1, double v2, int N){
257 double // *endv1 = v1 + N,
258 sum = 0;
259 #ifdef DO_PARALLEL
260 #pragma omp parallel for num_threads(CORES) reduction(+:sum)
261 #endif
262 for(int i=0; i<=N; i++) sum += v2 * v1[i];
263 }
264 */
265
266
267
268 void linearprod2by2( double * v1, double v2, int N, double *inout){
269 double *endv1 = v1 + (N / 2) * 2,
270 *end = v1 + N;
271 for(; v1 < endv1; v1+=2, inout+=2) {
272 inout[0] += v2 * v1[0];
273 inout[1] += v2 * v1[1];
274 }
275 if (v1 < end) inout[0] += v2 * v1[0];
276 }
277
278 /*
279 void linearprod4by4( double * v1, double v2, int N){
280 double*endv1 = v1 + (N / 4) * 4,
281 *end = v1 + N,
282 sum = 0;
283 for(; v1 < endv1; v1+=4) {
284 sum+= v2 * v1[0] + v2 * v1[1] + v2 * v1[2]+ v2 * v1[3];
285 }
286 for(; v1 < end; v1++) sum += v2 * v1[0];
287 }
288
289
290 void linearprod8by8( double * v1, double v2, int N){
291 double
292 *endv1 = v1 + (N / 8) * 8,
293 *end = v1 + N,
294 sum = 0;
295 for(; v1 < endv1; v1+=8) {
296 sum+= v2 * v1[0] + v2 * v1[1]+ v2 * v1[2] + v2 * v1[3] +
297 v2 * v1[4] + v2 * v1[5]+ v2 * v1[6]+ v2 * v1[7];
298 }
299 for(; v1 < end; v1++) sum += v2 * v1[0];
300 }
301 */
302
303 //bool pr = true;
304 void linearX(double *x, double y, int len, double *inout, int n) {
305 // if (n < 0) { }
306 // if (pr) { printf("mode = %d\n", n); pr = false; }
307 // 0 : 7.9
308 // 1: 7.55
309 // 2: 7.8
310 // 3:7.58
311 //4: 7.5
312 // 5: 7.4!
313 //6:7.4
314 //7: 7.9
315 // 8: "ewige" schleife
316
317 switch(n) {
318 case 0 : BUG; // linearprod(x, y, len); break;
319 case LINEAR_BASE : linearprod2by2(x, y, len, inout); break;
320 case 2 : BUG; //linearprod4by4(x, y, len); break;
321 case 3 : BUG; // linearprod8by8(x, y, len); break;
322 #ifdef FMA_AVAILABLE
323 case 4 : BUG; //avx_linearprodDfma(x, y, len); break;
324 #endif
325 #ifdef AVX
326 case 5 : BUG; //avx_linearprodDnearfma(x, y, len); break;
327 case LINEAR_AVX : avx_linearprodD(x, y, len, inout); break; // best one kernel
328 case 7 : BUG; // avx_linearprodDP(x, y, len); break; //best
329 case 8 : BUG //avx_linearprodDK(x, y, len); break; // kahan
330 #else
331 case 4: case 5: case 6: case 7: case 8 : linearprod2by2(x, y, len, inout); break;
332 #endif
333
334 #ifdef DO_PARALLEL
335 case LINEAR_AVX_PARALLEL :
336 #ifdef AVX
337 BUG; // avx_linearprodDparallel(x, y, len); break;
338 #endif
339 case LINEAR_BASE_PARALLEL : BUG; //linearprodP(x, y, len); break;// parallel, nicht-vectoriell
340 #else
341 case LINEAR_AVX_PARALLEL :
342 #ifdef AVX
343 BUG; // avx_linearprodD(x, y, len); break;
344 #endif
345 case LINEAR_BASE_PARALLEL : BUG; // linearprod2by2(x, y, len); break;
346 #endif
347 default : {{ ERR("method not available"); }} //
348 }
349 }
350
351
0
1 #ifndef LINEAR_RU_H
2 #define LINEAR_RU_H 1
3
4
5 #define LINEAR_AVX 6
6 #define LINEAR_BASE 1
7 #define LINEAR_AVX_PARALLEL 9
8 #define LINEAR_BASE_PARALLEL 10
9
10 void linearX(double *x, double y, int len, double *out, int n);
11
12
13 #endif
11 Authors
22 Martin Schlather, schlather@math.uni-mannheim.de
33
4 Copyright (C) 2015 -- Martin Schlather
4 Copyright (C) 2015 -- 2017 Martin Schlather
55
66 This program is free software; you can redistribute it and/or
77 modify it under the terms of the GNU General Public License
1919 */
2020 #include <R_ext/Lapack.h>
2121 #include "RandomFieldsUtils.h"
22 #include "init_RandomFieldsUtils.h"
22 #include "zzz_RandomFieldsUtils.h"
2323 #include "General_utils.h"
2424
2525
2929 if (x <= 0.0) return RF_NA; // not programmed yet
3030 double exp_dummy,
3131 dummy = 0.0,
32 logx = 2.0 * Log(0.5 * x),
32 logx = 2.0 * LOG(0.5 * x),
3333 x1 = 1.5,
3434 x2 = nu + 1.5,
3535 value = 1.0,
3838
3939
4040 do {
41 dummy += logx - Log(x1) - Log(FABS(x2));
41 dummy += logx - LOG(x1) - LOG(FABS(x2));
4242 exp_dummy = EXP(dummy);
4343 value += (1 - 2 * (x2 < 0)) * fsign * exp_dummy;
44 // printf("%f %f %f %f\n", value, fsign, x1, x2);
44 // printf("%10g %10g %10g %10g\n", value, fsign, x1, x2);
4545 x1 += 1.0;
4646 x2 += 1.0;
4747 fsign = factor_Sign * fsign;
199199 /* Gausian model */
200200 double Gauss(double x) {
201201 return EXP(- x * x);
202 // printf("%f %f\n", *x, *v);
202 // printf("%10g %10g\n", *x, *v);
203203 }
204204 double logGauss(double x) {
205205 return - x * x;
230230 double logWM(double x, double nu1, double nu2, double factor) {
231231 // check calling functions, like hyperbolic and gneiting if any changings !!
232232
233 // printf("%f %f %f %f\n", x, nu1, nu2, factor);
234
233 // printf("%10g %10g %10g %10g\n", x, nu1, nu2, factor);
234
235 #ifdef DO_PARALLEL
236 double loggamma;
237 #else
235238 static double loggamma, loggamma1old, loggamma2old, loggamma_old,
236239 nuOld=-RF_INF,
237240 nu1old=-RF_INF,
238 nu2old=-RF_INF
239 ;
241 nu2old=-RF_INF;
242 #endif
240243 double v, y,
241244 nu = 0.5 * (nu1 + nu2),
242245 nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES,
243 scale = factor==0.0 ? 1.0 : factor * SQRT(nuThres);
246 scale = 1.0;
247 if (factor!=0.0) scale = factor * SQRT(nuThres);
244248 bool simple = nu1 == nu2 || nu > MATERN_NU_THRES;
249 double bk[MATERN_NU_THRES + 1L];
245250
246251 if (x > LOW_MATERN) {
252 #ifdef DO_PARALLEL
253 if (simple) loggamma = lgammafn(nuThres);
254 else loggamma = 0.5*(lgammafn(nu1) + lgammafn(nu2));
255 #else
247256 if (simple) {
248257 if (nuThres != nuOld) {
249258 nuOld = nuThres;
261270 }
262271 loggamma = 0.5 * (loggamma1old + loggamma2old);
263272 }
273 #endif
274
264275 y = x * scale;
265 v = LOG2 + nuThres * Log(0.5 * y) - loggamma +
266 Log(bessel_k(y, nuThres, 2.0)) - y;
276 v = LOG2 + nuThres * LOG(0.5 * y) - loggamma +
277 LOG(bessel_k_ex(y, nuThres, 2.0, bk)) - y;
267278 } else v = 0.0;
268279
269280 if (nu > MATERN_NU_THRES) { // factor!=0.0 &&
272283 y = x * factor / 2;
273284 w = logGauss(y);
274285
275 //if (nu>100) printf("nu=%f %e %e %e\n", nu, v, g, w);
286 //if (nu>100) printf("nu=%10g %10e %10e %10e\n", nu, v, g, w);
276287
277288 v = v * g + (1.0 - g) * w;
278289 if (nu1 != nu2) { // consistenz zw. nu1, nu2 und nuThres wiederherstellen
281292
282293 // if (!R_FINITE(v)) ERR("non-finite value in the whittle-matern model -- value of 'nu' is much too large");
283294
284 //if (nu>100) printf("v=%f \n", v);
295 //if (nu>100) printf("v=%10g \n", v);
285296 }
286297
287298 return v;
294305 }
295306
296307 double DWM(double x, double nu, double factor) {
308 #ifdef DO_PARALLEL
309 double loggamma;
310 #else
297311 static double nuOld=RF_INF;
298312 static double loggamma;
313 #endif
299314 double y, v,
300315 nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES,
301 scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0;
316 scale = 1.0;
317 if (factor != 0.0) scale = factor * SQRT(nuThres);
318 double bk[MATERN_NU_THRES + 1L];
302319
303320 if (x > LOW_MATERN) {
304 if (nuThres!=nuOld) {
321 #ifdef DO_PARALLEL
322 loggamma = lgammafn(nuThres);
323 #else
324 if (nuThres!=nuOld) {
305325 nuOld = nuThres;
306326 loggamma = lgammafn(nuThres);
307327 }
328 #endif
308329 y = x * scale;
309 v = - 2.0 * EXP(nuThres * Log(0.5 * y) - loggamma +
310 Log(bessel_k(y, nuThres - 1.0, 2.0)) - y);
330 v = - 2.0 * EXP(nuThres * LOG(0.5 * y) - loggamma +
331 LOG(bessel_k_ex(y, nuThres - 1.0, 2.0, bk)) - y);
311332 } else {
312333 v = (nuThres > 0.5) ? 0.0 : (nuThres < 0.5) ? INFTY : 1.253314137;
313334 }
325346 }
326347
327348 double DDWM(double x, double nu, double factor) {
349 #ifdef DO_PARALLEL
350 double gamma;
351 #else
328352 static double nuOld=RF_INF;
329353 static double gamma;
354 #endif
330355 double y, v,
331356 nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES,
332 scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0,
333 scaleSq = scale * scale;
334
357 scale = 1.0;
358 if (factor != 0.0) scale = factor * SQRT(nuThres);
359 double scaleSq = scale * scale,
360 bk[MATERN_NU_THRES + 1L];
361
335362 if (x > LOW_MATERN) {
363 #ifdef DO_PARALLEL
364 gamma = gammafn(nuThres);
365 #else
336366 if (nuThres!=nuOld) {
337367 nuOld = nuThres;
338368 gamma = gammafn(nuThres);
339369 }
370 #endif
340371 y = x * scale;
341372 v = POW(0.5 * y , nuThres - 1.0) / gamma *
342 (- bessel_k(y, nuThres - 1.0, 1.0) + y * bessel_k(y, nuThres - 2.0, 1.0));
373 (- bessel_k_ex(y, nuThres - 1.0, 1.0, bk)
374 + y * bessel_k_ex(y, nuThres - 2.0, 1.0, bk));
343375 } else {
344376 v = (nu > 1.0) ? -0.5 / (nu - 1.0) : INFTY;
345377 }
358390 }
359391
360392 double D3WM(double x, double nu, double factor) {
393 #ifdef DO_PARALLEL
394 double gamma;
395 #else
361396 static double nuOld=RF_INF;
362397 static double gamma;
398 #endif
363399 double y, v,
364400 nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES,
365401 scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0,
366402 scaleSq = scale * scale;
367
403 double bk[MATERN_NU_THRES + 1L];
404
368405 if (x > LOW_MATERN) {
406 #ifdef DO_PARALLEL
407 gamma = gammafn(nuThres);
408 #else
369409 if (nuThres!=nuOld) {
370410 nuOld = nuThres;
371411 gamma = gammafn(nuThres);
372412 }
413 #endif
373414 y = x * scale;
374415 v = POW(0.5 * y , nuThres - 1.0) / gamma *
375 ( 3.0 * bessel_k(y, nuThres - 2.0, 1.0)
376 -y * bessel_k(y, nuThres - 3.0, 1.0));
416 ( 3.0 * bessel_k_ex(y, nuThres - 2.0, 1.0, bk)
417 -y * bessel_k_ex(y, nuThres - 3.0, 1.0, bk));
377418 } else {
378419 v = 0.0;
379420 }
392433 }
393434
394435 double D4WM(double x, double nu, double factor) {
395 static double nuOld=RF_INF;
396 static double gamma;
397436 double y, v,
398437 nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES,
399438 scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0,
400439 scaleSq = scale * scale;
401
402 // printf("x=%f nu=%f\n", x, nuThres);
440 double bk[MATERN_NU_THRES + 1L];
441
442 // printf("x=%10g nu=%10g\n", x, nuThres);
403443
404444 if (x > LOW_MATERN) {
445 #ifdef DO_PARALLEL
446 double gamma = gammafn(nuThres);
447 #else
448 static double nuOld=RF_INF;
449 static double gamma;
405450 if (nuThres!=nuOld) {
406451 nuOld = nuThres;
407452 gamma = gammafn(nuThres);
408453 }
454 #endif
409455 y = x * scale;
410456 v = 0.25 * POW(0.5 * y , nuThres - 3.0) / gamma *
411 (+ 6.0 * (nuThres - 3.0 - y * y) * bessel_k(y, nuThres - 3.0, 1.0)
412 + y * (3.0 + y * y) * bessel_k(y, nuThres - 4.0, 1.0));
457 (+ 6.0 * (nuThres - 3.0 - y * y) * bessel_k_ex(y, nuThres - 3.0, 1.0, bk)
458 + y * (3.0 + y * y) * bessel_k_ex(y, nuThres - 4.0, 1.0, bk));
413459 } else {
414 v = (nuThres > 2.0) ? 0.75 / ((nuThres - 1.0) * (nuThres - 2.0)) : INFTY;
460 v = INFTY;
461 if (nuThres > 2.0) v = 0.75 / ((nuThres - 1.0) * (nuThres - 2.0));
415462 }
416463 v *= scaleSq * scaleSq;
417464
425472 v = v * g + (1.0 - g) * w;
426473 }
427474
428 // printf("v=%f\n", v);
475 // printf("v=%10g\n", v);
429476
430477 return v;
431478 }
499546 double incomplete_gamma(double start, double end, double s) {
500547 // int_start^end t^{s-1} e^{-t} \D t
501548
502 // print("incomplete IN s=%f e=%f s=%f\n", start, end, s);
549 // print("incomplete IN s=%10g e=%10g s=%10g\n", start, end, s);
503550
504551 double
505552 v = 0.0,
528575 w = pgamma(start, s, 1.0, 0, 0); // q, shape, scale, lower, log
529576 if (R_FINITE(end)) w -= pgamma(end, s, 1.0, 0, 0);
530577
531 // print("incomplete s=%f e=%f s=%f v=%f g=%f w=%f\n", start, end, s, v, gammafn(s), w);
578 // print("incomplete s=%10g e=%10g s=%10g v=%10g g=%10g w=%10g\n", start, end, s, v, gammafn(s), w);
532579
533580 return v + gammafn(s) * w * factor;
534581 }
33 Martin Schlather, schlather@math.uni-mannheim.de
44
55
6 Copyright (C) 2016 Martin Schlather
6 Copyright (C) 2016 -- 2017 Martin Schlather
77
88 This program is free software; you can redistribute it and/or
99 modify it under the terms of the GNU General Public License
2424 #ifdef DO_PARALLEL
2525 #include <omp.h>
2626 #endif
27 #include <unistd.h>
2728 #include "General_utils.h"
2829 #include "kleinkram.h"
29 #include "init_RandomFieldsUtils.h"
30 #include <unistd.h>
30 #include "zzz_RandomFieldsUtils.h"
3131
3232 #define PLverbose 2
3333
3434 // IMPORTANT: all names of general must be at least 3 letters long !!!
3535 const char *basic[basicN] =
36 { "printlevel", "skipchecks", "cPrintlevel", "seed", "asList", "cores",
37 "verbose"};
36 { "printlevel","cPrintlevel", "seed", "cores", "skipchecks", "asList",
37 "verbose", "kahanCorrection", "helpinfo"};
3838
3939 const char * solve[solveN] =
40 { "use_spam", "spam_tol", "spam_min_p", "svdtol",
41 "solve_method", "spam_min_n", "spam_sample_n", "spam_factor",
42 "spam_pivot", "max_chol", "max_svd", "eigen2zero"
40 { "use_spam", "spam_tol", "spam_min_p", "svdtol", "eigen2zero",
41 "solve_method", "spam_min_n", "spam_sample_n", "spam_factor", "spam_pivot",
42 "max_chol", "max_svd", "pivot",
43 "pivot_idx", // dynamic parameter
44 "pivot_relerror", "pivot_max_deviation", "pivot_max_reldeviation",
45 "det_as_log", "pivot_actual_size", "pivot_check"
4346 //, "tmp_delete"
4447 };
4548
5053 int ownallN[ownprefixN] = {basicN, solveN};
5154
5255
53 int PL=C_PRINTLEVEL;
56 int PL = C_PRINTLEVEL,
57 CORES = 1;
5458
5559 utilsparam GLOBAL = {
5660 basic_START,
5963
6064
6165
62 #if defined(unix) || defined(__unix__) || defined(__unix)
66 //#if defined(unix) || defined(__unix__) || defined(__unix)
67 #if defined (__unix__) || (defined (__APPLE__) && defined (__MACH__))
6368 int numCPU = sysconf(_SC_NPROCESSORS_ONLN);
6469 #else
6570 int numCPU = MAXINT;
6873
6974
7075 void setparameterUtils(int i, int j, SEXP el, char name[LEN_OPTIONNAME],
71 bool isList) {
76 bool isList, int VARIABLE_IS_NOT_USED local) {
77 #ifdef DO_PARALLEL
78 if (local != isGLOBAL) ERR1("Options specific to RandomFieldsUtils, here '%.50s', can be set only via 'RFoptions' outside any parallel code.", name);
79 #endif
80 utilsparam *options = &GLOBAL;
7281 switch(i) {
7382 case 0: {// general
74 basic_param *gp;
75 gp = &(GLOBAL.basic);
83 basic_param *gp = &(options->basic);
7684 switch(j) {
7785 case 0: { // general options
7886 int threshold = 1000; //PL_ERRORS;
7987 gp->Rprintlevel = INT;
80 PL = gp->Cprintlevel =
81 gp->Rprintlevel <= threshold ? gp->Rprintlevel : threshold;
88 if (gp->Rprintlevel > threshold) gp->Rprintlevel = threshold;
89 PL = gp->Cprintlevel = gp->Rprintlevel + PLoffset;
8290 }
8391 break;
84 case 1: gp->skipchecks = LOG; break;
85 case 2: PL = gp->Cprintlevel = INT; break;
86 case 3: gp->seed = Integer(el, name, 0, true); break;
87 case 4: gp->asList = LOG; break;
88 case 5: gp->cores = POSINT;
92 case 1: PL = gp->Cprintlevel = INT + PLoffset ;
93 break;
94 case 2: gp->seed = Integer(el, name, 0, true); break;
95 case 3: gp->cores = POSINT;
8996 if (gp->cores > numCPU) {
9097 WARN1("number of 'cores' is set to %d", numCPU);
9198 gp->cores = numCPU;
9299 }
93 #ifdef DO_PARALLEL
94 omp_set_num_threads(gp->cores);
95 #else
96 if (gp->cores != 1)
97 ERR("The system does not allow for OpenMP: the value 1 is kept for'cores'.");
100 #ifndef DO_PARALLEL
101 if (gp->cores != 1) {
102 gp->cores = 1;
103 PRINTF("The system does not allow for OpenMP: the value 1 is kept for 'cores'.");
104 }
98105 #endif
99106 break;
107 case 4: gp->skipchecks = LOGI; break;
108 case 5: gp->asList = LOGI; break;
100109 case 6 : if (!isList) {
101 PL = gp->Cprintlevel = gp->Rprintlevel = (LOG) * PLverbose;
110 PL = gp->Cprintlevel = gp->Rprintlevel = 1 + (LOGI * (PLverbose - 1));
102111 }
103112 break;
104 default: BUG;
113 case 7: gp->kahanCorrection = LOGI; break;
114 case 8: gp->helpinfo = LOGI; break;
115 default: BUG;
105116 }}
106117 break;
107118
108119 case 1: {
109 solve_param *so = &(GLOBAL.solve);
120 // printf("name = %.50s %d\n", name, j);
121
122 solve_param *so = &(options->solve);
110123 switch(j) {
111 case 0: {
112 double sparse = NUM;
113 so->sparse = !R_finite(sparse) ? Nan : sparse==0.0 ? False : True ;
114 break;
115 }
124 case 0: so->sparse = USRLOG; break; // USRLOGRELAXED??
116125 case 1: so->spam_tol = POS0NUM; break;
117126 case 2: so->spam_min_p = POS0NUM; break;
118127 case SOLVE_SVD_TOL: so->svd_tol = POS0NUM; break;
119 case 4: GetName(el, name, InversionNames, nr_user_InversionMethods,
128 case 4: so->eigen2zero = POS0NUM; break;
129 case 5:
130 GetName(el, name, InversionNames, nr_user_InversionMethods,
120131 (int) NoInversionMethod, (int) NoFurtherInversionMethod,
121132 (int *)so->Methods, SOLVE_METHODS);
122133 break;
123 case 5: so->spam_min_n = POSINT; break;
124 case 6: so->spam_sample_n = POSINT; break;
125 case 7: so->spam_factor = POSINT; break;
126 case 8: so->pivot = POSINT;
127 if (so->pivot > 2) so->pivot = PIVOT_NONE;
134 case 6: so->spam_min_n = POSINT; break;
135 case 7: so->spam_sample_n = POSINT; break;
136 case 8: so->spam_factor = POSINT; break;
137 case 9: so->pivotsparse = POSINT;
138 if (so->pivotsparse > 2) so->pivotsparse = PIVOT_NONE;
128139 break;
129 case 9: so->max_chol = POSINT; break;
130 case 10: so->max_svd = POSINT; break;
131 // case 11: so->tmp_delete = LOG; break;
132 case 11: so->eigen2zero = POS0NUM; break;
133 default: BUG;
140 case 10: so->max_chol = POSINT; break;
141 case 11: so->max_svd = POS0INT; break;
142 // case 11: so->tmp_delete = LOGI; break;
143 case 12: so->pivot = POS0INT;
144 if (so->pivot > PIVOTLAST) so->pivot = PIVOT_UNDEFINED;
145 break;
146 case 13: if (!isList) {
147 int len = length(el);
148 if (len == 0) {
149 if (so->pivot_idx_n > 0) FREE(so->pivot_idx);
150 } else {
151 if (so->pivot_idx_n != len) {
152 FREE(so->pivot_idx);
153 so->pivot_idx = (int*) MALLOC(len * sizeof(int));
154 }
155 for (int L=0; L<len; L++) so->pivot_idx[L] = Integer(el, name, L);
156 }
157 so->pivot_idx_n = len;
158 }
159 break;
160 case 14: so->pivot_relerror = POS0NUM; break;
161 case 15: so->max_deviation = POSNUM; break;
162 case 16: so->max_reldeviation = POS0NUM; break;
163 case 17: so->det_as_log = LOGI; break;
164 case 18: so->actual_size = POS0NUM; break;
165 case 19: so->pivot_check = USRLOG; break;
166 default: BUG;
134167 }}
135168 break;
136169
137170 default: BUG;
138171 }
139172
140 }
141
142
143 void getparameterUtils(SEXP *sublist) {
144 int i, k;
173 }
174
175
176 void getparameterUtils(SEXP sublist, int i,
177 int VARIABLE_IS_NOT_USED local) {
178 //printf("hier %d\n", i);
179 int k = 0;
145180 //#define ADD(ELT) {printf(#ELT"\n");SET_VECTOR_ELT(sublist[i], k++, ELT);}
146 i = 0; {
181 #ifdef DO_PARALLEL
182 // if (local != isGLOBAL) ERR("Options specific to RandomFieldsUtils can be obtained only on a global level and outside any parallel code.");
183 #endif
184 utilsparam *options = &GLOBAL;
185 switch(i) {
186 case 0 : {
147187 // printf("OK %d\n", i);
148 k = 0;
149 basic_param *p = &(GLOBAL.basic);
188 basic_param *p = &(options->basic);
150189 ADD(ScalarInteger(p->Rprintlevel));
190 ADD(ScalarInteger(p->Cprintlevel - PLoffset));
191 ADD(ScalarInteger(p->seed));
192 ADD(ScalarInteger(p->cores));
151193 ADD(ScalarLogical(p->skipchecks));
152 ADD(ScalarInteger(p->Cprintlevel));
153 ADD(ScalarInteger(p->seed));
154194 ADD(ScalarLogical(p->asList));
155 ADD(ScalarInteger(p->cores));
156 ADD(ScalarLogical(p->Rprintlevel >= PLverbose))
157 }
195 ADD(ScalarLogical(p->Rprintlevel >= PLverbose));
196 ADD(ScalarLogical(p->kahanCorrection));
197 ADD(ScalarLogical(p->helpinfo));
198 }
199 break;
158200
159 i++; {
160 k = 0;
161 solve_param *p = &(GLOBAL.solve);
201 case 1 : {
202 solve_param *p = &(options->solve);
162203 // printf("sparse user interface %d %d; %d %d\n", p->sparse, ExtendedBoolean(p->sparse), NA_LOGICAL, NA_INTEGER);
163204 ADD(ExtendedBooleanUsr(p->sparse));
164205 ADD(ScalarReal(p->spam_tol));
165206 ADD(ScalarReal(p->spam_min_p));
166207 ADD(ScalarReal(p->svd_tol));
167 SET_VECTOR_ELT(sublist[i], k++,
208 ADD(ScalarReal(p->eigen2zero));
209 SET_VECTOR_ELT(sublist, k++,
168210 String((int*) p->Methods, InversionNames, SOLVE_METHODS,
169211 (int) NoFurtherInversionMethod));
170212 ADD(ScalarInteger(p->spam_min_n));
171213 ADD(ScalarInteger(p->spam_sample_n));
172214 ADD(ScalarInteger(p->spam_factor));
173 ADD(ScalarInteger(p->pivot));
215 ADD(ScalarInteger(p->pivotsparse));
174216 ADD(ScalarInteger(p->max_chol));
175217 ADD(ScalarInteger(p->max_svd));
176 ADD(ScalarReal(p->eigen2zero));
218 ADD(ScalarInteger(p->pivot));
219 //if (true)
220 SET_VECTOR_ELT(sublist, k++,
221 Int(p->pivot_idx, p->pivot_idx_n, p->pivot_idx_n));
222 // else ADD(ScalarInteger(NA_INTEGER));
177223 // ADD(ScalarLogical(p->tmp_delete));
178 }
179
180
181 assert (i == ownprefixN - 1);
182 }
183
224 ADD(ScalarReal(p->pivot_relerror));
225 ADD(ScalarReal(p->max_deviation));
226 ADD(ScalarReal(p->max_reldeviation));
227 ADD(ScalarLogical(p->det_as_log));
228 ADD(ScalarInteger(p->actual_size));
229 ADD(ExtendedBooleanUsr(p->pivot_check));
230 }
231 break;
232 default : BUG;
233 }
234 }
235
236 void delparameterUtils(int VARIABLE_IS_NOT_USED local) {
237 #ifdef DO_PARALLEL
238 if (local != isGLOBAL) RFERROR("'pivot_idx' cannot be freed on a local level");
239 #endif
240 utilsparam *options = &GLOBAL;
241 FREE(options->solve.pivot_idx);
242 }
184243
185244 void getErrorString(errorstring_type errorstring){
245 #ifdef DO_PARALLEL
246 STRCPY(errorstring, "error occurred in package RandomFieldsUtils");
247 #else
186248 strcopyN(errorstring, ERRORSTRING, MAXERRORSTRING);
187 }
188
189 void setErrorLoc(errorloc_type errorloc){
249 #endif
250 }
251
252 void setErrorLoc(errorloc_type VARIABLE_IS_NOT_USED errorloc){
253 #ifndef DO_PARALLEL
190254 strcopyN(ERROR_LOC, errorloc, nErrorLoc);
191 }
192
193
194
255 #endif
256 }
257
11 Authors
22 Martin Schlather, schlather@math.uni-mannheim.de
33
4 Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer
4 Copyright (C) 2015 -- 2017 Martin Schlather
55
66 This program is free software; you can redistribute it and/or
77 modify it under the terms of the GNU General Public License
2727 #include <Rinternals.h>
2828 #include "General_utils.h"
2929 #include "own.h"
30 #include "init_RandomFieldsUtils.h"
30 #include "zzz_RandomFieldsUtils.h"
31 #include "Utils.h"
3132
3233
3334
3435 // local
35 char ERRMSG[LENERRMSG], MSG[LENERRMSG], BUG_MSG[250], MSG2[LENERRMSG];
36
37 // globally needed
36 #ifdef DO_PARALLEL
37 #else
38 char ERRMSG[LENERRMSG], MSG[LENERRMSG], MSG2[LENERRMSG];
3839 errorloc_type ERROR_LOC="";
3940 errorstring_type ERRORSTRING;
41 #endif
4042
4143
42 SEXP attachRFoptionsUtils() {
43 // NList = 0;
44
45 // printf("UTx %ld\n", (long) getUtilsParam);
46
47 attachRFoptions(ownprefixlist, ownprefixN, ownall, ownallN,
48 setparameterUtils, NULL, getparameterUtils);
49
44 SEXP attachRandomFieldsUtils(SEXP show) {
45 attachRFoptions(ownprefixlist, ownprefixN,
46 ownall, ownallN,
47 setparameterUtils, NULL,
48 getparameterUtils,
49 delparameterUtils,
50 0, true);
51 if (INTEGER(show)[0]) {
5052 #ifdef DO_PARALLEL
51 basic_param *gp = &(GLOBAL.basic);
52 omp_set_num_threads(gp->cores);
53 PRINTF("'RandomFieldsUtils' will use OMP\n");
54 #else
55 PRINTF("'RandomFieldsUtils' will NOT use OMP\n");
5356 #endif
54
57 }
5558 return R_NilValue;
5659 }
5760
58 SEXP detachRFoptionsUtils(){
59 #ifdef DO_PARALLEL
60 omp_set_num_threads(1);
61 #endif
61 SEXP detachRandomFieldsUtils(){
6262 detachRFoptions(ownprefixlist, ownprefixN);
63 freeGlobals();
6364 return R_NilValue;
6465 }
44 Martin Schlather, schlather@math.uni-mannheim.de
55
66
7 Copyright (C) 2015 Martin Schlather
7 Copyright (C) 2015 -- 2017 Martin Schlather
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
2727 #define rfutil_own_H 1
2828 #include "Options_utils.h"
2929
30 void setparameterUtils(int i, int j, SEXP el, char name[200], bool isList);
31 void getparameterUtils(SEXP *sublist);
30 void setparameterUtils(int i, int j, SEXP el, char name[200], bool isList, int local);
31 void getparameterUtils(SEXP sublist, int i, int local);
32 void delparameterUtils(int local);
3233 void set_num_threads();
3334
3435
3839 **ownall[ownprefixN];
3940 extern int ownallN[ownprefixN];
4041
42 #define HELPINFO(M) if (GLOBAL.basic.helpinfo) WARN1("%.50s\nNote that you can unable the above information by 'RFoptions(helpinfo=FALSE)'.\n", M) //
4143
4244 #endif
4345
44
55 Collection of system specific auxiliary functions
66
7 Copyright (C) 2001 -- 2015 Martin Schlather,
7 Copyright (C) 2001 -- 2017 Martin Schlather,
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
3030
3131 */
3232
33
34
35 #define SIMD_AVAILABLE 1
36
37
38
39 #include "RandomFieldsUtils.h"
40 #include "General_utils.h"
41 #ifdef XXXSCHLATHERS_MACHINE
42
43 #ifdef SIMD_AVAILABLE
44 #include <x86intrin.h>
45 #endif
46
47
48
33 #define BUG assert(false);
34
35 #include <assert.h>
4936 #include "kleinkram.h"
37 #include "scalar.h"
38 #include "intrinsics.h"
39 #include "Basic_utils.h"
40 #include "errors_messages.h"
41 #include "zzz_RandomFieldsUtils.h"
42
5043
5144 #define Nmodi 9
5245 name_type modi = { "1x1", "2x2", "4x4", "8x8", "near", "simple", "precise", "kahan", "1x1p"};
53
5446
5547
5648 typedef unsigned int uint32;
5951 #define size 8
6052 #define vectorlen (256 / (size * 8))
6153 #define repet 8
62 #define VECTOR _mm256_loadu_pd
63 #define SET_0(NR) sum##NR = _mm256_setzero_pd()
64 #define P_0(NR) prod##NR = _mm256_setzero_pd()
65 #define SUMUP(NR, nr) sum##NR = _mm256_add_pd(sum##NR, sum##nr)
54 #define atonce (vectorlen * repet)
55 #define SET_0(NR) sum##NR = ZERODOUBLE
56 #define P_0(NR) prod##NR = ZERODOUBLE
57 #define SUMUP(NR, nr) sum##NR = ADDDOUBLE(sum##NR, sum##nr)
58 #define ADDN(NR) \
59 prod##NR = MULTDOUBLE(LOADuDOUBLE(x + i + NR * vectorlen), \
60 LOADuDOUBLE(y + i + NR * vectorlen)); \
61 sum##NR = ADDDOUBLE(sum##NR, prod##NR)
62
63
64 #if (7 != repet - 1)
65 wrong repet length
66 #endif
67 #if (3 != vectorlen - 1)
68 wrong vector length
69 #endif
70
71
72 #ifdef AVX
73
74 #ifdef FMA_AVAILABLE
6675 #define ADDF(NR) \
67 sum##NR = _mm256_fmadd_pd(VECTOR(x + i + NR * vectorlen),\
68 VECTOR(y + i + NR * vectorlen), sum##NR)
69 #define ADDN(NR) \
70 prod##NR = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \
71 VECTOR(y + i + NR * vectorlen)); \
72 sum##NR = _mm256_add_pd(sum##NR, prod##NR)
73
74
75 #ifdef SIMD_AVAILABLE
76
77 #ifdef FMA_AVAILABLE
78 double avx_scalarproductDfma(double * x, double * y, int len) {
79 int i = 0,
80 lenM = len - (repet * vectorlen - 1);
76 sum##NR = _mm256_fmadd_pd(LOADuDOUBLE(x + i + NR * vectorlen),\
77 LOADuDOUBLE(y + i + NR * vectorlen), sum##NR)
78 double avx_scalarprodDfma(double * x, double * y, int len) {
79 int i = 0,
80 lenM = len - (atonce - 1);
8181 __m256d SET_0(0);
8282 double *D = (double *) &sum0;
8383
84 if ( len >= vectorlen * repet) {
84 if (len >= atonce) {
8585 __m256d SET_0(1), SET_0(2), SET_0(3), SET_0(4), SET_0(5), SET_0(6),SET_0(7);
86 #if (7 != repet - 1)
87 wrong repet length
88 #endif
89 for (; i < lenM; i += repet * vectorlen) {
86 for (; i < lenM; i += atonce) {
9087 ADDF(0); ADDF(1); ADDF(2); ADDF(3); ADDF(4); ADDF(5); ADDF(6); ADDF(7);
91 #if (7 != repet - 1)
92 wrong repet length
93 #endif
94 }
95 SUMUP(0, 1); SUMUP(2, 3); SUMUP(4, 5); SUMUP(6, 7); SUMUP(0, 2); SUMUP(4, 6); SUMUP(0, 4);
96 #if (7 != repet - 1)
97 wrong repet length
98 #endif
99 }
100 lenM = len - vectorlen + 1;
101 for (; i < lenM; i += vectorlen) { // could unroll further
102 ADDF(0);
103 }
104 double sum = D[0] + D[1] + D[2] + D[3];
105 #if (3 != vectorlen - 1)
106 wrong vector length
107 #endif
108
109 for (; i < len; ++i) sum += x[i] * y[i];
110 return sum;
111 }
112 #endif
113
114
115 double avx_scalarproductDnearfma(double * x, double * y, int len) {
88 }
89 SUMUP(0, 1); SUMUP(2, 3); SUMUP(4, 5); SUMUP(6, 7);
90 SUMUP(0, 2); SUMUP(4, 6); SUMUP(0, 4);
91 }
92 lenM = len - vectorlen + 1;
93 for (; i < lenM; i += vectorlen) { ADDF(0); }
94 double sum = D[0] + D[1] + D[2] + D[3];
95 for (; i < len; i++) sum += x[i] * y[i];
96 return sum;
97 }
98 #endif
99
100
101 double avx_scalarprodDnearfma(double * x, double * y, int len) {
116102 // deutlich genauer zum 0 tarif
117103 int i = 0,
118 lenM = len - (repet * vectorlen - 1);
119 __m256d SET_0(0), SET_0(1), SET_0(2), SET_0(3), SET_0(4), SET_0(5), SET_0(6),SET_0(7),
120 P_0(0), P_0(1), P_0(2), P_0(3), P_0(4), P_0(5), P_0(6),P_0(7);
121
122 double *D = (double *) &sum0;
123
124 if ( len >= vectorlen * repet) {
125 for (; i < lenM; i += repet*vectorlen) {
126 //
104 lenM = len - (atonce - 1);
105 __m256d SET_0(0), SET_0(1), SET_0(2), SET_0(3), SET_0(4), SET_0(5),
106 SET_0(6),SET_0(7),
107 P_0(0), P_0(1), P_0(2), P_0(3), P_0(4), P_0(5), P_0(6), P_0(7);
108 double *D = (double *) &sum0;
109
110 if ( len >= atonce) {
111 for (; i < lenM; i += atonce) {
127112 ADDN(0); ADDN(1); ADDN(2); ADDN(3); ADDN(4); ADDN(5); ADDN(6); ADDN(7);
128 #if (7 != repet - 1)
129 wrong repet length
130 #endif
131 }
132 SUMUP(0, 1); SUMUP(2, 3); SUMUP(4, 5); SUMUP(6, 7); SUMUP(0, 2); SUMUP(4, 6); SUMUP(0, 4);
133 // SUMUP(0, 1); SUMUP(0, 2); SUMUP(0, 3); SUMUP(0, 4); SUMUP(0, 5); SUMUP(0, 6); SUMUP(0, 7);
134 #if (7 != repet - 1)
135 wrong repet length
136 #endif
137 }
138 lenM = len - vectorlen + 1;
139 for (; i < lenM; i += vectorlen) { // could unroll further
140 ADDN(0);
141 }
142
143 double sum = D[0] + D[1] + D[2] + D[3];
144 #if (3 != vectorlen - 1)
145 wrong vector length
146 #endif
147
148 for (; i < len; ++i) sum += x[i] * y[i];
149 return sum;
150 }
151
152
153 #define ADD(NR) \
154 prod0 = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \
155 VECTOR(y + i + NR * vectorlen)); \
156 sum0 = _mm256_add_pd(sum0, prod0)
157 double avx_scalarproductD(double * x, double * y, int len) {
113 }
114 SUMUP(0, 1); SUMUP(2, 3); SUMUP(4, 5); SUMUP(6, 7);
115 SUMUP(0, 2); SUMUP(4, 6); SUMUP(0, 4);
116 }
117 lenM = len - vectorlen + 1;
118 for (; i < lenM; i += vectorlen) { ADDN(0); }
119 double sum = D[0] + D[1] + D[2] + D[3];
120 for (; i < len; i++) sum += x[i] * y[i];
121
122 return sum;
123 }
124
125
126 #define ADDM(NR) \
127 prod0 = MULTDOUBLE(LOADuDOUBLE(x + i + NR * vectorlen), \
128 LOADuDOUBLE(y + i + NR * vectorlen)); \
129 sum0 = ADDDOUBLE(sum0, prod0)
130 double avx_scalarprodD(double * x, double * y, int len) {
158131 int i = 0,
159 lenM = len - (repet * vectorlen - 1);
132 lenM = len - (atonce - 1);
160133 __m256d SET_0(0), P_0(0);
161134 double *D = (double *) &sum0;
162135
163 if ( len >= vectorlen * repet) {
164 for (; i < lenM; i += repet*vectorlen) {
165 //
166 ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); ADD(6); ADD(7);
167 #if (7 != repet - 1)
168 wrong repet length
169 #endif
170 }
171 }
172
173 lenM = len - vectorlen + 1;
174 for (; i < lenM; i += vectorlen) { // could unroll further
175 ADD(0);
176 }
177
178 double sum = D[0] + D[1] + D[2] + D[3];
179 #if (3 != vectorlen - 1)
180 wrong vector length
181 #endif
182
183 for (; i < len; ++i) sum += x[i] * y[i];
184 return sum;
185 }
186
187
188 double avx_scalarproductDP(double * x, double * y, int len) {
136 if ( len >= atonce) {
137 for (; i < lenM; i += atonce) {
138 ADDM(0); ADDM(1); ADDM(2); ADDM(3); ADDM(4); ADDM(5); ADDM(6); ADDM(7);
139 }
140 }
141 lenM = len - vectorlen + 1;
142 for (; i < lenM; i += vectorlen) { ADDM(0); }
143 double sum = D[0] + D[1] + D[2] + D[3];
144 for (; i < len; i++) sum += x[i] * y[i];
145 return sum;
146 }
147
148 //#p r a g m a o m p declare reduction(minabs : int : omp_out = a bs(omp_in) > omp_out ? omp_out : a bs(omp_in) initializer (omp_priv=LARGENUM)
149
150 #if defined OpenMP4
151 double avx_scalarprodDparallel(double * x, double * y, int len) {
152 int i = 0,
153 lenM = len - (atonce - 1);
154 __m256d SET_0(0), P_0(0);
155 double *D = (double *) &sum0;
156
157 #ifdef DO_PARALLEL
158 #pragma omp declare reduction(addpd: __m256d: \
159 omp_out = ADDDOUBLE(omp_out, omp_in)) \
160 initializer (omp_priv = ZERODOUBLE)
161 #endif
162
163 if ( len >= atonce) {
164 #ifdef DO_PARALLEL
165 #pragma omp parallel for num_threads(CORES) reduction(addpd:sum0) schedule(dynamic, 100)
166 #endif
167 for (i=0; i < lenM; i += atonce) {
168 ADDM(0); ADDM(1); ADDM(2); ADDM(3); ADDM(4); ADDM(5); ADDM(6); ADDM(7);
169 }
170 }
171 lenM = len - vectorlen + 1;
172 for (; i < lenM; i += vectorlen) { ADDM(0); }
173 double sum = D[0] + D[1] + D[2] + D[3];
174 for (; i < len; i++) sum += x[i] * y[i];
175 return sum;
176 }
177 #endif
178
179
180 double avx_scalarprodDP(double * x, double * y, int len) {
189181 int i = 0,
190 lenM = len - (repet * vectorlen - 1);
182 lenM = len - (atonce - 1);
191183 __m256d SET_0(0), SET_0(1), P_0(0);
192184 double *D = (double *) &sum1;
193
194 if ( len >= vectorlen * repet) {
195
185 if ( len >= atonce) {
196186 for (; i < lenM; ) {
197187 int lenMM = i + vectorlen * (repet * 10 + 1);
198188 if (lenMM > lenM) lenMM = lenM;
199 sum0 = _mm256_mul_pd(VECTOR(x + i), VECTOR(y + i));
189 sum0 = MULTDOUBLE(LOADuDOUBLE(x + i), LOADuDOUBLE(y + i));
200190 i += vectorlen;
201 for (; i < lenMM; i += repet*vectorlen) {
202 ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); ADD(6); ADD(7);
203 #if (7 != repet - 1)
204 wrong repet length
205 #endif
206 }
207 sum1 = _mm256_add_pd(sum0, sum1);
191 for (; i < lenMM; i += atonce) {
192 ADDM(0); ADDM(1); ADDM(2); ADDM(3); ADDM(4); ADDM(5); ADDM(6); ADDM(7);
193 }
194 sum1 = ADDDOUBLE(sum0, sum1);
208195 }
209196 }
210197
211198 lenM = len - vectorlen + 1;
212 for (; i < lenM; i += vectorlen) { // could unroll further
213 prod0 = _mm256_mul_pd(VECTOR(x + i), VECTOR(y + i));
214 sum1 = _mm256_add_pd(sum1, prod0);
215 }
216
217 double sum = D[0] + D[1] + D[2] + D[3];
218 #if (3 != vectorlen - 1)
219 wrong vector length
220 #endif
221
222 for (; i < len; ++i) {
223 // printf("final %d\n", i);
224 sum += x[i] * y[i];
225 }
226 return sum;
227 }
228
229
230
231
232 #define ADDK(NR) \
233 prod0 = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \
234 VECTOR(y + i + NR * vectorlen)); \
235 sum2 = _mm256_sub_pd(prod0, sum1);\
236 sum3 = _mm256_add_pd(sum0, sum2); \
237 sum1 = _mm256_sub_pd(sum3, sum0); \
238 sum0 = sum3; \
239 sum1 = _mm256_sub_pd(sum1, sum2);
240 double avx_scalarproductDK(double * x, double * y, int len) {
241 // Kahan enhanced
199 for (; i < lenM; i += vectorlen) {
200 prod0 = MULTDOUBLE(LOADuDOUBLE(x + i), LOADuDOUBLE(y + i));
201 sum1 = ADDDOUBLE(sum1, prod0);
202 }
203 double sum = D[0] + D[1] + D[2] + D[3];
204 for (; i < len; i++) sum += x[i] * y[i];
205 return sum;
206 }
207
208
209 #define ADDK(NR) \
210 prod0 = MULTDOUBLE(LOADuDOUBLE(x + i + NR * vectorlen), \
211 LOADuDOUBLE(y + i + NR * vectorlen)); \
212 sum2 = SUBDOUBLE(prod0, sum1); \
213 sum3 = ADDDOUBLE(sum0, sum2); \
214 sum1 = SUBDOUBLE(sum3, sum0); \
215 sum0 = sum3; \
216 sum1 = SUBDOUBLE(sum1, sum2);
217 double avx_scalarprodDK(double * x, double * y, int len) {
218 // Kahan
242219 int i = 0,
243 lenM = len - (repet * vectorlen - 1);
220 lenM = len - (atonce - 1);
244221 __m256d SET_0(0), // sum
245 SET_0(1), // c
222 SET_0(1),
246223 SET_0(2), // y
247 SET_0(3), // t
224 SET_0(3), // t
248225 P_0(0),
249226 P_0(1);
250 double *D = (double *) &sum0;
251
252 if ( len >= vectorlen * repet) {
253 for (; i < lenM; i += repet*vectorlen) {
254 //
255 ADDK(0); ADDK(1); ADDK(2); ADDK(3); ADDK(4); ADDK(5); ADDK(6); ADDK(7);
256 #if (7 != repet - 1)
257 wrong repet length
258 #endif
259 }
260 }
261 lenM = len - vectorlen + 1;
262 for (; i < lenM; i += vectorlen) { // could unroll further
263 ADDK(0);
264 }
265 sum0 = _mm256_add_pd(sum0, prod1);
266
267 double sum = D[0] + D[1] + D[2] + D[3];
268 #if (3 != vectorlen - 1)
269 wrong vector length
270 #endif
271
272 for (; i < len; ++i) sum += x[i] * y[i];
273 return sum;
274 }
275
276 // end if simd
277 #endif
278
279
280 double scalarproductf64( double * v1, double * v2, int N){
227 double *D = (double *) &sum0;
228 if ( len >= atonce) {
229 for (; i < lenM; i += atonce) {
230 ADDK(0); ADDK(1); ADDK(2); ADDK(3); ADDK(4); ADDK(5); ADDK(6); ADDK(7);
231 }
232 }
233 lenM = len - vectorlen + 1;
234 for (; i < lenM; i += vectorlen) { ADDK(0); }
235 sum0 = ADDDOUBLE(sum0, prod1);
236 double sum = D[0] + D[1] + D[2] + D[3];
237
238 for (; i < len; i++) sum += x[i] * y[i];
239 return sum;
240 }
241
242 #endif
243
244
245 double scalarprod( double * v1, double * v2, int N){
281246 double *endv1 = v1 + N,
282247 sum = 0;
283 for(; v1!= endv1; v1++, v2++) sum+= v2[0] * v1[0];
284 return sum;
285 }
286
287
288
289 double scalarproductf64P( double * v1, double * v2, int N){
290 double //*endv1 = v1 + N,
248 for(; v1!= endv1; v1++, v2++) sum += v2[0] * v1[0];
249 return sum;
250 }
251
252
253 double scalarprodP( double * v1, double * v2, int N){
254 double
255 sum = 0.0;
256 #ifdef DO_PARALLEL
257 #pragma omp parallel for num_threads(CORES) if (N > 200) reduction(+:sum) schedule(dynamic, 100)
258 #endif
259 for(int i=0; i<=N; i++) sum += v2[i] * v1[i];
260 return sum;
261 }
262
263
264 double scalarprod2by2( double * v1, double * v2, int N){
265 double *endv1 = v1 + (N / 2) * 2,
266 *end = v1 + N,
291267 sum = 0;
292 #ifdef DO_PARALLEL
293 #pragma omp parallel for reduction(+:sum)
268 for(; v1 < endv1; v1 += 2, v2 += 2) sum += v2[0] * v1[0] + v2[1] * v1[1];
269 if (v1 < end) sum += v2[0] * v1[0];
270 return sum;
271 }
272
273
274 double scalarprod4by4( double * v1, double * v2, int N){
275 double*endv1 = v1 + (N / 4) * 4,
276 *end = v1 + N,
277 sum = 0;
278 for(; v1 < endv1; v1 += 4, v2 += 4)
279 sum += v2[0] * v1[0] + v2[1] * v1[1] + v2[2] * v1[2]+ v2[3] * v1[3];
280 for(; v1 < end; v1++, v2++) sum += v2[0] * v1[0];
281 return sum;
282 }
283
284
285 double scalarprod8by8( double * v1, double * v2, int N){
286 double
287 *endv1 = v1 + (N / 8) * 8,
288 *end = v1 + N,
289 sum = 0.0;
290 for(; v1 < endv1; v1 += 8, v2 += 8)
291 sum += v2[0] * v1[0] + v2[1] * v1[1]+ v2[2] * v1[2] + v2[3] * v1[3] +
292 v2[4] * v1[4] + v2[5] * v1[5]+ v2[6] * v1[6]+ v2[7] * v1[7];
293 for(; v1 < end; v1++, v2++) sum += v2[0] * v1[0];
294 return sum;
295 }
296
297
298
299 double scalarprodPX( double * V1, double * V2, int N){
300 #define AtOnce 16
301 double
302 *endv1 = V1 + (N / AtOnce) * AtOnce,
303 *end = V1 + N,
304 sum = 0;
305 #ifdef DO_PARALLEL
306 #pragma omp parallel for num_threads(CORES) if (N > 200) reduction(+:sum) schedule(dynamic, 50)
307 #endif
308 for(double *v1=V1; v1 < endv1; v1 += AtOnce) {
309 double *v2 = V2 + (V1 - v1);
310 sum += v2[0] * v1[0] + v2[1] * v1[1]+ v2[2] * v1[2] + v2[3] * v1[3] +
311 v2[4] * v1[4] + v2[5] * v1[5]+ v2[6] * v1[6]+ v2[7] * v1[7] +
312 v2[8] * v1[8] + v2[9] * v1[9]+ v2[10] * v1[10] + v2[11] * v1[11] +
313 v2[12] * v1[12] + v2[13] * v1[13]+ v2[14] * v1[14]+ v2[15] * v1[15];
314 }
315 double
316 *v1 = V1 + (N / AtOnce),
317 *v2 = V2 + (V1 - v1);
318 for(; v1 < end; v1++, v2++) sum += v2[0] * v1[0];
319 return sum;
320 }
321
322
323
324 //bool pr = true;
325 double scalarX(double *x, double *y, int len, int n) {
326 if (n < 0) {
327 }
328 // if (pr) { printf("mode = %d\n", n); pr = false; }
329 // 0 : 7.9
330 // 1: 7.55
331 // 2: 7.8
332 // 3:7.58
333 //4: 7.5
334 // 5: 7.4!
335 //6:7.4
336 //7: 7.9
337 // 8: "ewige" schleife
338
339 switch(n) {
340 case 0 : return scalarprod(x, y, len);
341 case SCALAR_BASE : return scalarprod2by2(x, y, len);
342 case 2 : return scalarprod4by4(x, y, len);
343 case 3 : return scalarprod8by8(x, y, len);
344 #ifdef FMA_AVAILABLE
345 case 4 : return avx_scalarprodDfma(x, y, len);
346 #endif
347 #ifdef AVX
348 case 5 : return avx_scalarprodDnearfma(x, y, len);
349 case SCALAR_AVX : return avx_scalarprodD(x, y, len); // best one kernel
350 case 7 : return avx_scalarprodDP(x, y, len); //best
351 case SCALAR_KAHAN : return avx_scalarprodDK(x, y, len); // kahan
294352 #else
295 ERR("parallel not allowed");
296 #endif
297 for(int i=0; i<=N; i++) sum += v2[i] * v1[i];
298 return sum;
299 }
300
301
302 double scalarproduct2by2f64( double * v1, double * v2, int N){
303 double *endv1 = v1 + N,
304 sum = 0;
305 for(; v1!= endv1; v1+=2, v2+=2) {
306 sum+= v2[0] * v1[0] + v2[1] * v1[1];
307 }
308 return sum;
309 }
310
311
312 double scalarproduct4by4f64( double * v1, double * v2, int N){
313 double*endv1 = v1 + N,
314 sum = 0;
315 for(; v1 < endv1; v1+=4, v2+=4) {
316 sum+= v2[0] * v1[0] + v2[1] * v1[1] + v2[2] * v1[2]+ v2[3] * v1[3];
317 }
318 return sum;
319 }
320
321
322 double scalarproduct8by8f64( double * v1, double * v2, int N){
323 double *endv1 = v1 + N,
324 sum = 0;
325 for(; v1!= endv1; v1+=8, v2+=8) {
326 sum+= v2[0] * v1[0] + v2[1] * v1[1]+ v2[2] * v1[2] + v2[3] * v1[3] +
327 v2[4] * v1[4] + v2[5] * v1[5]+ v2[6] * v1[6]+ v2[7] * v1[7];
328 }
329 return sum;
330 }
331
353 case 4: case 5: case 6: case 7: case 8 : return scalarprod2by2(x, y, len);
354 #endif
355
356 #ifdef DO_PARALLEL
357 case SCALAR_AVX_PARALLEL :
358 #if defined AVX and defined OpenMP
359 return avx_scalarprodDparallel(x, y, len);
360 #endif
361 case SCALAR_BASE_PARALLEL : return scalarprodP(x, y, len);// parallel, nicht-vectoriell
362 #else
363 case SCALAR_AVX_PARALLEL :
364 #ifdef AVX
365 return avx_scalarprodD(x, y, len);
366 #endif
367 case SCALAR_BASE_PARALLEL : return scalarprod2by2(x, y, len);
368 #endif
369 default : ERR("method not available");
370 }
371 return RF_NAN;
372 }
373
374
375
332376
333377 SEXP scalarX(SEXP x, SEXP y, SEXP mode) {
334378 int len = length(x);
335379 if (length(y) != len) ERR("x and y differ in length");
336 int n = Match((char*) CHAR(STRING_ELT(mode, 0)), modi, Nmodi);
337 if (n < 0) ERR("unknown modus");
380 int n;
381 if (length(mode) == 0) n = -1;
382 else {
383 n = Match((char*) CHAR(STRING_ELT(mode, 0)), modi, Nmodi);
384 if (n < 0) ERR("unknown modus");
385 }
338386 SEXP Ans;
339387 PROTECT(Ans = allocVector(REALSXP, 1));
340388 double *ans = REAL(Ans);
341 switch(n) {
342 case 0 : *ans = scalarproductf64(REAL(x), REAL(y), len); break;
343 case 1 : *ans = scalarproduct2by2f64(REAL(x), REAL(y), len); break;
344 case 2 : *ans = scalarproduct4by4f64(REAL(x), REAL(y), len); break;
345 case 3 : *ans = scalarproduct8by8f64(REAL(x), REAL(y), len); break;
346 case 4 :
347 #ifdef SIMD_AVAILABLE
348 *ans = avx_scalarproductDnearfma(REAL(x), REAL(y), len); break;
349 #else
350 BUG;
351 #endif
352 case 5 :
353 #ifdef SIMD_AVAILABLE
354 *ans = avx_scalarproductD(REAL(x), REAL(y), len); break;
355 #else
356 BUG;
357 #endif
358 case 6 :
359 #ifdef SIMD_AVAILABLE
360 *ans = avx_scalarproductDP(REAL(x), REAL(y), len); break;
361 #else
362 BUG;
363 #endif
364 case 7 :
365 #ifdef SIMD_AVAILABLE
366 *ans = avx_scalarproductDK(REAL(x), REAL(y), len); break;
367 #else
368 BUG;
369 #endif
370 case 8 : *ans = scalarproductf64P(REAL(x), REAL(y), len); break;
371 default : BUG;
372 }
373
389 *ans = scalarX(REAL(x), REAL(y), len, n);
374390 UNPROTECT(1);
375391 return Ans;
376392 }
377
378 #else
379 SEXP scalarX(SEXP VARIABLE_IS_NOT_USED x, SEXP VARIABLE_IS_NOT_USED y,
380 SEXP VARIABLE_IS_NOT_USED mode) { BUG; }
381
382
383 #endif // SCHLATHERS_MACHINE
0
1 #ifndef SCALAR_RU_H
2 #define SCALAR_RU_H 1
3
4
5 #define SCALAR_AVX 6
6 #define SCALAR_KAHAN 8
7 #define SCALAR_BASE 1
8 #define SCALAR_AVX_PARALLEL 9
9 #define SCALAR_BASE_PARALLEL 10
10
11 // double scalarX(double *x, double *y, int len, int n);
12
13
14 #endif
11 Authors
22 Martin Schlather, schlather@math.uni-mannheim.de
33
4 Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer, Martin Kroll
4 Copyright (C) 2015 -- 2017 Martin Schlather, Reinhard Furrer, Martin Kroll
55
66 This program is free software; you can redistribute it and/or
77 modify it under the terms of the GNU General Public License
2323 #include <omp.h>
2424 #endif
2525 #include <R_ext/Lapack.h>
26
27 #define LOCAL_ERRORSTRING
28 #define WHICH_ERRORSTRING pt->err_msg
2629 #include "RandomFieldsUtils.h"
2730 #include "own.h"
28 #include "init_RandomFieldsUtils.h"
31 #include "zzz_RandomFieldsUtils.h"
2932 #include "General_utils.h"
33 #include "kleinkram.h"
34 #include "linear.h"
35
36
37
38 // 0 : 7.9
39 // 1: 7.55
40 // 2: 7.8
41 // 3:7.58
42 //4: 7.5
43 // 5: 7.4!
44 //6:7.4
45 //7: 7.9
46 // 8:
47
48 #define SCALAR(A,B,C) scalarX(A,B,C,NR)
49 #define LINEAR(A,B,C,D) linearX(A,B,C,D,6)
50
51 /* three trials n=2500 | 2 crs usr/sys/elap | new with linear (1;2crs)
52 0 : 8.140 8.076 8.036
53 1 : 6.288 6.296 6.284 | 6.988 0.012 5.665 | 6.032; 6.672 0.004 5.395
54 2 : 6.164 6.288 6.244
55 3 : 6.596 6.696 6.636
56 4 : ---
57 5 : 6.112 6.092 6.080 | 6.736 0.008 5.464
58 6 : 6.084 6.112 6.020 | 6.652 0.008 5.383 | 5.600; 6.756 0.008 3.413
59
60 7 : 6.300 6.208 6.176
61 8 : 7.828 7.836 7.792
62 9 : 10.24 10.10 10.00
63 10: >1min
64 2+10: >1min
65 10+2:9.14 9.24 9.23
66 2+9: 6.18 6.13 6.08 | 6.968 0.020 5.640
67 9+2:10.2 10.11 10.00
68 */
3069
3170
3271 const char * InversionNames[nr_InversionMethods] = {
33 "cholesky", "svd", "eigen", "sparse",
72 "cholesky", "svd", "eigen", "sparse",
3473 "method undefined",
3574 "qr", "lu",
36 "no method left", "direct formula", "diagonal"};
75 "no method left",
76 "direct formula",
77 "diagonal"};
3778
3879
3980 // double *A_= A, *B_= B;
4081 // i_ = N,
4182
42
43
83 #define KAHAN GLOBAL.basic.kahanCorrection
4484
4585 #define CMALLOC(WHICH, N, TYPE) { \
4686 int _N_ = N; \
4787 if (pt->WHICH##_n < _N_) { \
48 if (pt->WHICH##_n < 0) BUG; \
88 if (pt->WHICH##_n < 0) BUG; \
4989 FREE(pt->WHICH); \
5090 pt->WHICH##_n = _N_; \
5191 if ((pt->WHICH = (TYPE *) CALLOC(_N_, sizeof(TYPE))) == NULL) \
72112 UNCONDFREE(pt->WHICH); \
73113 pt->WHICH##_n = 0; \
74114 }
75
115
116
117 double Determinant(double *M, int size, bool log) {
118 int sizeP1 = size + 1,
119 sizeSq = size * size;
120 if (log) {
121 double tmp = 0.0;
122 for (int i=0; i<sizeSq; i+=sizeP1) tmp += LOG(M[i]);
123 return tmp;
124 }
125 double tmp = 1.0;
126 for (int i=0; i<sizeSq; i+=sizeP1) tmp *= M[i];
127 return tmp;
128 }
129
130 double cumProd(double *D, int size, bool log) {
131 if (log) {
132 double dummy = 0.0;
133 for (int i = 0; i < size; dummy += LOG(D[i++]));
134 return dummy;
135 }
136 double dummy = 1.0;
137 for (int i = 0; i < size; dummy *= D[i++]);
138 return dummy;
139 }
140
141
76142
77143 void solve_DELETE0(solve_storage *x) {
78144 FREE(x->iwork);
79145 FREE(x->ipiv);
80146
81 FREE(x->pivot);
147 FREE(x->pivotsparse);
148 FREE(x->pivot_idx);
82149 FREE(x->xlnz);
83150 FREE(x->snode);
84151 FREE(x->xsuper);
101168 FREE(x->w2);
102169 FREE(x->U);
103170 FREE(x->D);
104
171
105172 FREE(x->workLU);
173 FREE(x->diagonal);
106174
107175 FREE(x->lnz);
108176 FREE(x->DD);
120188 }
121189 void solve_NULL(solve_storage* x) {
122190 if (x == NULL) return;
123 x->iwork_n = x->ipiv_n =
124 x->pivot_n = x->xlnz_n = x->snode_n = x->xsuper_n = x->xlindx_n =
125 x->invp_n = x->cols_n = x->rows_n =x->lindx_n = x->xja_n =
126 //
127 x->SICH_n = x->MM_n = x->workspaceD_n = x->workspaceU_n =
128 x->VT_n = x->work_n = x->w2_n = x->U_n = x->D_n = x->workLU_n =
129 x->lnz_n = x->DD_n = x->w3_n = x->result_n =
130 0;
131
191 MEMSET(x, 0, sizeof(solve_storage));
132192 x->nsuper = x->nnzlindx = x->size = -1;
133193 x->method = NoInversionMethod;
134194 for (int i=0; i<SOLVE_METHODS; x->newMethods[i++] = NoInversionMethod);
135
136 x->iwork = x->ipiv =
137 x->pivot = x->xlnz = x->snode = x->xsuper = x->xlindx =
138 x->invp = x->cols = x->rows = x->lindx = x->xja =
139 NULL;
140
141 x->SICH = x->MM = x->workspaceD = x->workspaceU =
142 x->VT = x->work = x->w2 = x->U = x->D = x->workLU =
143 x->lnz = x->DD = x->w3 = x->result = x->to_be_deleted = NULL;
144 }
145
146
147 int solve3(double *M, int size, bool posdef,
148 double *rhs, int rhs_cols,
149 double *result, double *logdet
150 ){
151 assert(size <= 3);
152 if (size <= 0) SERR("matrix in 'solvePosDef' of non-positive size.");
153
195 x->actual_pivot = PIVOT_UNDEFINED;
196 }
197
198 double inline det3(double *M, int size) {
154199 double det;
155200 switch(size){ // Abfrage nach Groesse der Matrix M + Berechnung der Determinante per Hand
156201 case 1: det = M[0];
165210 default : BUG;
166211 break;
167212 }
168
169 if (det == 0 || (posdef && det < 0)) return ERRORFAILED;
170 if (logdet != NULL) *logdet = Log(det);
213 return det;
214 }
215
216 int logdet3(double det, bool posdef, double *logdet, bool log) {
217 if (posdef && det < 0) return ERRORFAILED;
218 if (logdet != NULL) {
219 if (log) {
220 if (det <= 0) return ERRORFAILED;
221 *logdet = LOG(det);
222 } else *logdet = det;
223 }
224 return NOERROR;
225 }
226
227 int solve3(double *M, int size, bool posdef,
228 double *rhs, int rhs_cols,
229 double *result, double *logdet, bool log,
230 solve_storage *pt
231 ){
232
233 assert(size <= 3);
234 if (size <= 0) SERR("matrix in 'solvePosDef' of non-positive size.");
235
236 double det = det3(M, size);
237 if (logdet3(det, posdef, logdet, log) != NOERROR) return ERRORFAILED;
171238
172239 double detinv = 1.0 / det; // determinant of inverse of M
173240
244311 return NOERROR;
245312 }
246313
247 int chol3(double *M, int size, double *res){
314 int chol3(double *M, int size, double *res, solve_storage *pt){
248315 // UNBEDINGT in sqrtRHS.cc auch aendern
249316 assert(size <= 3);
250 if (size <= 0) SERR("matrix in 'solvePosDef' of non-positive size.");
317 if (size <= 0) SERR("matrix in 'solvePosDef' not of positive size.");
251318 // if (M[0] < 0) return ERRORFAILED;
252319 res[0] = SQRT(M[0]);
253320 if (size == 1) return NOERROR;
254321 res[1] = 0.0;
255 res[size] = M[size] / res[0];
256 res[size + 1] = SQRT(M[size + 1] - res[size] * res[size]);
322 res[size] = res[0] > 0.0 ? M[size] / res[0] : 0.0;
323 double dummy = M[size + 1] - res[size] * res[size];
324 res[size + 1] = SQRT(MAX(0.0, dummy));
257325 if (size == 2) return NOERROR;
258326 res[2] = res[5] = 0.0;
259 res[6] = M[6] / res[0];
260 res[7] = (M[7] - res[3] * res[6]) / res[4];
261 res[8] = SQRT(M[8] - res[6] * res[6] - res[7] * res[7]);
327 res[6] = res[0] > 0.0 ? M[6] / res[0] : 0.0;
328 res[7] = res[4] > 0.0 ? (M[7] - res[3] * res[6]) / res[4] : 0.0;
329 dummy = M[8] - res[6] * res[6] - res[7] * res[7];
330 res[8] = SQRT(MAX(0.0, dummy));
262331 return NOERROR;
263 }
332 }
333
334
335
336 void Sort(double *RESULT, int size, int rhs_cols, int *pi, int *rank,
337 double *dummy) {
338 orderingInt(pi, size, 1, rank);
339 int i=0,
340 totalRHS = size * rhs_cols;
341 while(i < size && i == rank[i]) i++;
342 while (i < size) {
343 int stored_i = i,
344 read = i;
345 double *p_write = NULL,
346 *p_read = RESULT + read;
347 for (int k=0; k<rhs_cols; k++) dummy[k] = p_read[k * size];
348 while (true) {
349 int write = read;
350 p_write = RESULT + write;
351 read = rank[write];
352 rank[write] = write;
353 if (read == stored_i) {
354 for (int k=0; k<rhs_cols; k++) p_write[k*size]=dummy[k];
355 break;
356 }
357 p_read = RESULT + read;
358 for (int k=0; k<totalRHS; k+=size) p_write[k] = p_read[k];
359 }
360 while(i < size && i == rank[i]) i++;
361 }
362 }
363
364
365 // to do: fehlt: chol2solve(chol, x)
366
367
368 void chol2inv(double *MPT, int size) {
369 int sizeP1 = size + 1,
370 sizeSq = size * size,
371 NR = KAHAN ? SCALAR_KAHAN : SCALAR_AVX;
372
373 double *diagonal = (double *) MALLOC(sizeof(double) * size);
374 #ifdef DO_PARALLEL
375 #pragma omp parallel for num_threads(CORES) if (size > 60) schedule(dynamic, 20)
376 #endif
377 for (int k=0; k<size; k++) {
378 double *p_RESULT = MPT + k * sizeP1,
379 diagK = diagonal[k] = 1.0 / p_RESULT[0];
380 for (int i=1; i<size - k; i++) {
381 double *pM = p_RESULT + i * size;
382 p_RESULT[i] = (-diagK * pM[0] - SCALAR(pM + 1, p_RESULT + 1, i -1))
383 / pM[i];
384 }
385 // i == k
386 }
387
388 #ifdef DO_PARALLEL
389 #pragma omp parallel for num_threads(CORES) if (size > 60) schedule(dynamic, 20)
390 #endif
391 for (int k=0; k<size; k++) {
392 double *p_RESULT = MPT + k * size;
393 for (int i=size-1; i>k; i--) {
394 double *pM = MPT + i * size,
395 r = (p_RESULT[i] /= pM[i]);
396 diagonal[k] -= r *pM[k];
397 LINEAR(pM + k + 1, -r, i-k-1, p_RESULT + k + 1);
398 // for (int j=k+1; j<i; j++) p_RESULT[j] -= r * pM[j];
399 }
400 // i == k
401 }
402
403 for (int k=0; k<size; k++) {
404 double *pM = MPT + k * size;
405 pM[k] = diagonal[k] / pM[k];
406 }
407
408 for (int i2=0,i=0; i<size; i++, i2+=size + 1) {
409 int i3 = i2 + 1;
410 for (int j = i2 + size; j<sizeSq; j+=size)
411 MPT[j] = MPT[i3++];
412 }
413 FREE(diagonal);
414 }
264415
265416
266417 int doPosDef(double *M, int size, bool posdef,
267418 double *rhs, int rhs_cols, double *result, double *logdet,
268 bool sqrtOnly, solve_storage *Pt, solve_param *Sp
419 int calculate, solve_storage *Pt, solve_param *sp
269420 ){
270
271 /*
421 // it is ok to have
422 // ==15170== Syscall param sched_setaffinity(mask) points to unaddressable byte(s)
423 // caused by gcc stuff
424
425 // printf("doPosDef %ld %d %d rhs=%ld %d %ld %ld calc=%d %ld %ld\n",
426 // M, size, posdef, rhs, rhs_cols, result, logdet, calculate, Pt,sp);
427 /*
272428 M: (in/out) a square matrix (symmetry is not checked) of size x size;
273429 NOTE THAT THE CONTENTS OF M IS DESTROYED IFF NO RHS IS GIVEN
274430 AND result IS NOT GIVEN.
283439 the solution of the equality is returned in rhs
284440 rhs_cols : number of colums of the matrix on the right hand side
285441 result (out) : NULL or matrix of the size of the result (inverse matrix or
286 of size of the matrix on the right hand side); see also 'M' ans 'rhs'
442 of size of the matrix on the right hand side); see also 'M' and 'rhs'
287443 logdet (out): if not NULL the logarithm of the determinant is returned
288444 pt (in/out) : working space. If NULL, internal working spaces are used.
289445
305461 // http://www.nag.com/numeric/fl/nagdoc_fl23/xhtml/F01/f01intro.xml#
306462 assert(NA_LOGICAL == INT_MIN && NA_LOGICAL == NA_INTEGER); // nur zur sicherheit, wegen usr_bool
307463 // eigentlich sollte usr_bool unabhaengig davon funktionieren
464 assert(calculate != DETERMINANT ||
465 (logdet != NULL && result == NULL && rhs == NULL));
466 assert(calculate != MATRIXSQRT || (rhs == NULL && posdef));
467 assert(rhs_cols == 0 || rhs != NULL);
308468
309469 double *RESULT = result != NULL ? result : rhs_cols > 0 ? rhs : M;
310
311 //printf("%ld %ld %ld\ %ldn", RESULT, result, rhs, M); BUG;
312
313 if (size <= 3) {
470 assert(sp != NULL);
471
472 if (size <= 3 && sp->pivot == PIVOT_AUTO) {
314473 if (Pt != NULL) {
315474 Pt->method = direct_formula;
316475 Pt->size = size;
317476 }
318 return sqrtOnly
319 ? chol3(M, size, RESULT)
320 : solve3(M, size, posdef, rhs, rhs_cols, RESULT, logdet);
477 if (calculate == DETERMINANT)
478 return logdet3(det3(M, size), posdef, logdet, sp->det_as_log);
479 else if (calculate == MATRIXSQRT) return chol3(M, size, RESULT, Pt);
480 else return solve3(M, size, posdef, rhs, rhs_cols, RESULT, logdet,
481 sp->det_as_log, Pt);
321482 }
322483
323484 assert(SOLVE_METHODS >= 2);
324 solve_param
325 *sp = Sp == NULL ? &(GLOBAL.solve) : Sp;
326
485
327486 solve_storage *pt;
328487 if (Pt != NULL) {
329 pt = Pt;
330
488 pt = Pt;
331489 } else {
332490 pt = (solve_storage*) MALLOC(sizeof(solve_storage));
333491 solve_NULL(pt);
367525 break;
368526 }
369527 }
370 if (PL >= PL_FCTN_DETAILS)
371 PRINTF("random sampling: sparse=%d\n",
528 if (PL >= PL_FCTN_DETAILS) {
529 PRINTF("random sampling: sparse=%d\n",
372530 sparse == Nan ? NA_INTEGER : (int) sparse);
531 }
373532 }
374533 if (!random_sample || sparse == True) {
375534 int diag_nnzA = 0;
376535 //#ifdef DO_PARALLEL
377 //#pragma omp parallel for schedule(dynamic) reduction(+:nnzA,diag_nnzA)
536 //#pragma omp parallel for num_threads(CORES) schedule(dynamic,10) reduction(+:nnzA,diag_nnzA)
378537 //#endif
379538 for (int i=0; i<size; i++) {
380539 int end = i * sizeP1;
390549 sparse = (usr_bool) (nnzA <= sizeSq * (1.0 - sp->spam_min_p));
391550 spam_zaehler = nnzA + 1;
392551 if (PL >= PL_DETAILSUSER) {
393 if (diag) PRINTF("diagonal matrix detected\n");
394 else if (sparse == True)
552 if (diag) { PRINTF("diagonal matrix detected\n"); }
553 else if (sparse == True) {
395554 PRINTF("sparse matrix detected (%3.2f%% zeros)\n",
396555 100.0 * (1.0 - nnzA / (double) sizeSq));
397 else PRINTF("full matrix detected (%3.2f%% nonzeros)\n",
398 100.0 * nnzA / (double) sizeSq);
556 }
557 else { PRINTF("full matrix detected (%3.2f%% nonzeros)\n",
558 100.0 * nnzA / (double) sizeSq); }
399559 }
400560 }
401561 } else {
404564 int end = i * sizeP1;
405565 long j;
406566 for (j=i * size; j<end; j++) {
567 // printf("(%d %d %10g %d)\n", i, j, M[j], size);
407568 if (FABS(M[j]) > spam_tol) {
408569 diag = false;
409570 break;
414575 end = (i+1) * size;
415576 if (!posdef) {
416577 for (; j<end; j++) {
417 diag = false;
418 break;
419 }
420 }
421 }
422 }
423
424
578 if (FABS(M[j]) > spam_tol) {
579 diag = false;
580 break;
581 }
582 }
583 }
584 }
585 }
586
425587 if (diag) {
426588 pt->method = Diagonal;
427 if (PL>=PL_STRUCTURE) PRINTF("dealing with diagonal matrix\n");
589 if (PL>=PL_STRUCTURE) { PRINTF("dealing with diagonal matrix\n"); }
428590 if (logdet != NULL) {
429 double tmp = 0.0;
430 for (int i=0; i<sizeSq; i+=sizeP1) tmp += Log(M[i]);
431 *logdet = tmp;
591 *logdet = Determinant(M, size, sp->det_as_log);
592 if (calculate == DETERMINANT) return NOERROR;
432593 }
433594 if (rhs_cols == 0) {
434595 MEMCOPY(RESULT, M, sizeSq * sizeof(double));
435 if (sqrtOnly) {
596 if (calculate == MATRIXSQRT) {
436597 for (int i=0; i<sizeSq; i += sizeP1) {
437598 RESULT[i] = M[i] > 0.0 ? SQRT(M[i]) : 0.0;
438599 }
439 } else
600 } else {
440601 for (int i=0; i<sizeSq; i += sizeP1)
441602 RESULT[i] = M[i] <= 0.0 ? 0.0 : 1.0 / M[i];
603 }
442604 } else {
443605 CMALLOC(MM, size, double);
444606 for (int i=0; i<size; i++) {
453615 err = NOERROR;
454616 goto ErrorHandling;
455617 }
618
456619
457620 // size of matrix at least 4 x 4, and not diagonal
458621 InversionMethod *Meth;
490653
491654 // cholesky, QR, SVD, Eigen, LU always destroy original matrix M
492655 bool gesichert;
493 if ((gesichert = rhs_cols==0 && result == NULL)) {
656 if ((gesichert = rhs_cols==0 && result == NULL)) {
494657 if ((gesichert = (SOLVE_METHODS > sparse + 1 &&
495658 Meth[sparse + 1] != Meth[sparse] &&
496659 Meth[sparse + 1] != NoFurtherInversionMethod)
497 || (Meth[sparse] == SVD && sp->svd_tol > 0.0 && sqrtOnly)
660 || (Meth[sparse] == SVD && sp->svd_tol > 0.0 && calculate != SOLVE)
498661 )) { // at least two different Methods in the list
499662 CMALLOC(SICH, sizeSq, double);
500663 MEMCOPY(SICH, M, sizeSq * sizeof(double));
509672 MPT = MM;
510673 } else if (result != NULL) MPT = result;
511674
675
676 errorstring_type ErrStr;
677 STRCPY(ErrStr, "");
512678
513 // printf("gesichert %d\n", gesichert);
514 // int size4; size4 = MIN(5, size);printf("MPT\n"); for (int ii=0; ii<size4; ii++) {for (int jj=0; jj<size4; jj++) printf("%e ", M[ii + jj * size]); printf("\n");}; BUG;
515 // printf("%ld %ld %ld\n", (long) MPT, (long)M, long(result)); BUG;
516
517 // bool del = GLOBAL.solve.tmp_delete;
518 for (int m=0; m<SOLVE_METHODS && (m==0 || Meth[m] != Meth[m-1]); m++) {
679 for (int m=0; m<SOLVE_METHODS && (m==0 || Meth[m] != Meth[m-1]); m++) {
519680 pt->method = Meth[m];
520681 if (pt->method<0) break;
521 if (sqrtOnly) {
682 if (calculate != SOLVE) {
522683 if (pt->method == NoInversionMethod && m<=sparse) BUG;
523684 if (pt->method == NoFurtherInversionMethod) break;
524685 if (PL>=PL_STRUCTURE) {
525 PRINTF("method to calculate the square root : %s\n",
686 PRINTF("method to calculate the square root : %.50s\n",
526687 InversionNames[pt->method]);
527688 }
528689 } else {
529690 if (PL>=PL_STRUCTURE) {
530 PRINTF("method to calculate the inverse : %s\n",
691 PRINTF("method to calculate the inverse : %.50s\n",
531692 InversionNames[pt->method]);
532693 }
533694 }
541702 }
542703
543704 switch(pt->method) {
544 case Cholesky : // cholesky
705 case Cholesky : {
706 #define C_GERR(X,G) {STRCPY(ErrStr, X); FERR(X); err = ERRORM; goto G;}
707 #define C_GERR1(X,Y,G) {SPRINTF(ErrStr,X,Y); FERR(ErrStr);err = ERRORM; goto G;}
708 #define C_GERR2(X,Y,Z,G){SPRINTF(ErrStr,X,Y,Z);FERR(ErrStr);err=ERRORM; goto G;}
709 #define C_GERR3(X,Y,Z,A,G) {SPRINTF(ErrStr,X,Y,Z,A); FERR(ErrStr);err = ERRORM; goto G;}
710 int NR = KAHAN ? SCALAR_KAHAN : SCALAR_AVX;
545711 if (!posdef) CERR("Cholesky needs positive definite matrix");
546712 if (size > sp->max_chol)
547 CERR("matrix too large for Cholesky decomposition.");
713 CERR2("Matrix is too large for Cholesky decomposition. Maximum ist currently a %d x %d matrix. Increase 'max_chol' in 'RFoption' if necessary.",
714 sp->max_chol, sp->max_chol);
715
548716
549 // cmp for instance http://stackoverflow.com/questions/22479258/cholesky-decomposition-with-openmp
550
551 //printf("multicore = %d cores=%d\n", GLOBAL.basic.cores);
717 CMALLOC(diagonal, size > rhs_cols ? size : rhs_cols, double);
718 for (int i=0; i<size; i++) diagonal[i] = MPT[sizeP1 * i];
552719
553 err = NOERROR;
554 {
555 double *A = MPT;
556 for (int i=0; i<size; i++, A += size) {
557 double scalar;
558 SCALAR_PROD(A, A, i, scalar);
559 if (A[i] <= scalar) {
560 err = ERRORFAILED;
561 break;
720 pt->actual_pivot = PIVOT_UNDEFINED;
721
722 // printf("sp->pivot = %d\n", sp->pivot);
723
724 if (sp->pivot == PIVOT_NONE || sp->pivot == PIVOT_AUTO) {// cholesky
725
726 // cmp for instance http://stackoverflow.com/questions/22479258/cholesky-decomposition-with-openmp
727
728 // obere und untere dreiecksmatrix wird gelesen und obere geschrieben
729 err = NOERROR;
730 pt->actual_pivot = PIVOT_NONE;
731 {
732 double *A = MPT;
733 for (int i=0; i<size; i++, A += size) {
734 double sclr = SCALAR(A, A, i);
735 if (A[i] <= sclr) {
736 if (sp->pivot == PIVOT_NONE)
737 C_GERR3("Got %10e as %d-th eigenvalue.%.50s)'.",
738 A[i] - sclr, i, sp->pivot == PIVOT_NONE
739 ? " Try with 'RFoptions(pivot=PIVOT_DO" : "",
740 Pivot_Cholesky)
741 else C_GERR(".", Pivot_Cholesky);
742 break;
743 }
744 A[i] = SQRT(A[i] - sclr);
745
746 // double invsum = 1.0 / A[i];
747 double sum = A[i];
748 #ifdef DO_PARALLEL
749 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(size - i)) schedule(dynamic, 8)
750 #endif
751 // for (double *B=MPT + (i+1) * size; B<endB; B+=size) {
752 for (int j = i + 1; j < size; j++) {
753 double *B = MPT + j * size;
754 B[i] = (B[i] - SCALAR(A, B, i)) / sum;
755 }
562756 }
563 A[i] = SQRT(A[i] - scalar);
564
565 // double invsum = 1.0 / A[i];
566 double sum = A[i];
567 double *endB = MPT + sizeSq;
757 }
758
759 if (err == NOERROR) {
760 if (calculate == MATRIXSQRT) {
761 int deltaend = size - 1;
762 double *end = MPT + sizeSq;
763 for (double *p=MPT + 1; p<end; p+=sizeP1, deltaend--)
764 FILL_IN(p, deltaend, 0.0);
765 } else {
766 if (logdet != NULL) {
767 *logdet = Determinant(MPT, size, sp->det_as_log);
768 if (sp->det_as_log) *logdet *=2; else *logdet *= *logdet;
769 if (calculate == DETERMINANT) return NOERROR;
770 }
771
772 if (rhs_cols == 0) chol2inv(MPT, size);
773 else { // rhs_cols > 0
774 //int totalRHS = size * rhs_cols;
775 //if (result!=NULL) MEMCOPY(RESULT, rhs, sizeof(double)*totalRHS);
568776 #ifdef DO_PARALLEL
569 #pragma omp parallel for if (MULTIMINSIZE(size - i))
570 #endif
571 for (double *B=MPT + (i+1) * size; B<endB; B+=size) {
572 double scalar2;
573 SCALAR_PROD(A, B, i, scalar2);
574 //B[i] = invsum * (B[i] - scalar2);
575 B[i] = (B[i] - scalar2) / sum;
777 #pragma omp parallel for num_threads(CORES) if (rhs_cols > 30)
778 #endif
779 for (int k=0; k<rhs_cols; k++) {
780 double *p_RESULT = RESULT + k * size,
781 *p_rhs = rhs + k * size;
782 for (int i=0; i<size; i++) {
783 double *pM = MPT + i * size;
784 p_RESULT[i] = (p_rhs[i] - SCALAR(pM, p_RESULT, i)) / pM[i];
785 }
786 }
787
788 #ifdef DO_PARALLEL
789 #pragma omp parallel for num_threads(CORES) if (rhs_cols > 30)
790 #endif
791 for (int k=0; k<rhs_cols; k++) {
792 double *p_RESULT = RESULT + k * size;
793 for (int i=size-1; i>=0; i--) {
794 double *pM = MPT + i * size,
795 r = (p_RESULT[i] /= pM[i]);
796 LINEAR(pM, -r, i, p_RESULT);
797 // for (int j=0; j<i; j++) p_RESULT[j] -= r * pM[j];
798 }
799 }
800 }
801 } // not sqrt only
802 } // err == NOERROR
803 } else err = ERRORFAILED;
804
805 Pivot_Cholesky:
806 if (err != NOERROR && sp->pivot != PIVOT_NONE) {
807 if (PL > PL_DETAILS) { PRINTF("trying pivoting\n"); }
808 int actual_size = NA_INTEGER;
809 // code according to Helmut Harbrecht,Michael Peters,Reinhold Schneider
810 // talk: The pivoted Cholesky decomposition and its application to
811 // stochastic PDEs
812 // ebenso: untere dreiecksmatrix wird gelesen; obere geschrieben
813 if (pt->actual_pivot == PIVOT_NONE) {
814 // wiederherstellung der Diagonalen und der unteren dreiecksmatrix
815 for (int i=0; i<size; i++) MPT[sizeP1 * i] = diagonal[i];
816 }
817 int *pi;
818 if (sp->pivot == PIVOT_DO || sp->pivot == PIVOT_AUTO) {
819 FREE(pt->pivot_idx); // ALWAYS FREE IT!!! cp Chol(SEXP M)
820 pt->pivot_idx = (int*) MALLOC(size * sizeof(int));
821 pt->pivot_idx_n = size;
822 pt->actual_pivot = PIVOT_DO;
823 for (int i=0; i<size; i++) pt->pivot_idx[i] = i;
824 pt->actual_size = actual_size = size;
825 pi = pt->pivot_idx;
826 } else { // PIVOT_IDX
827 if (sp->pivot_idx_n < size || sp->actual_size > size) {
828 //printf("XA, %d %d %d\n", sp->pivot_idx_n , size, sp->actual_size);
829 CERR("pivot_idx does not have the correct length.\nSet 'RFoption(pivot_idx=, pivot_actual_size=)' to the attributes of a\npivoted Cholesky decomposition.");
576830 }
577 }
578 }
579
580 // see also http://www.wseas.us/e-library/conferences/2013/Dubrovnik/MATHMECH/MATHMECH-25.pdf
581 // http://ac.els-cdn.com/0024379586901679/1-s2.0-0024379586901679-main.pdf?_tid=bc5f2c8c-3117-11e6-80e1-00000aab0f02&acdnat=1465789050_ebfe7248d7a126bd2a301e97a3dbf914
582 if (false) {
583 //braucht 100 % mehr zeit als aufruf von dpotrf
584 // laesst sich nicht ohne weiteres
585 err = NOERROR;
586 int isize=0;
587 for (int i=0; i<size; i++, isize += size) {
588 double *A = MPT + isize;
589 for (int j=0; j<i; j++) {
590 int jsize = j * size;
831 actual_size = pt->actual_size = sp->actual_size;
832 if (actual_size > size) BUG;
833 FREE(pt->pivot_idx);
834 int bytes = size * sizeof(int);
835 pt->pivot_idx = (int*) MALLOC(bytes);
836 MEMCOPY(pt->pivot_idx, sp->pivot_idx, bytes);
837 pt->actual_pivot = PIVOT_IDX;
838 pt->pivot_idx_n = sp->pivot_idx_n;
839 pi = sp->pivot_idx;
840 }
841
842 err = NOERROR;
843 double
844 rel_thres = 0,
845 max_deviation = sp->max_deviation, // 1e-10,
846 max_reldeviation = sp->max_reldeviation, // 1e-10,
847 *Morig = gesichert ? SICH : M;
848 if (MPT == Morig || (rhs_cols > 0 && rhs == RESULT))
849 CERR("Pivoted cholesky cannot be performed on place! Either you are a programmer or you should contact the maintainer.");
850 for (int q=0; q<actual_size; q++) {
851 if (pt->actual_pivot == PIVOT_DO) {
591852 double
592 *B = MPT + jsize,
593 sum = A[j];
594 for (int k=0; k<j; k++) sum -= A[k] * B[k];
595 A[j] = sum / B[j];
853 max = RF_NEGINF,
854 deviation = 0.0;
855 int k,
856 argmax = NA_INTEGER;
857 for (k=q; k<size; k++) {
858 double dummy = diagonal[pi[k]];
859 // if (diagonal[pi[k]] < 0)
860
861 //printf("k=%d %10e %10e\n", k, dummy, -1e-15 * size * size);
862 if (dummy < -1e-4 * sp->pivot_relerror* size * size){
863 C_GERR1("matrix not positive definite or increase 'pivot_relerror' by at least factor %10g.", dummy * -1e4 / (size * size), ERR_CHOL);
864 }
865 deviation += dummy;
866 if (max < dummy) {
867 max = dummy;
868 argmax = k;
869 }
870 }
871 double dev = rel_thres * max_reldeviation;
872 if (deviation <= max_deviation || (q > 0 && deviation <= dev) ) {
873 actual_size = pt->actual_size = q;
874 if (sp->pivot_check != False) {
875 double largest = 0;
876 //printf("q=%d %d\n", q, size);
877 for (int i=q; i<size; i++) {
878 double *mpt = MPT + pi[i] * size;
879 for (int j=q; j<=i; j++) {
880 double absm = FABS(mpt[j]);
881 largest = absm > largest ? absm : largest;
882 // if(absm == largest || absm > 5) printf("%10e %d %d; %d\n", absm, i, j, size);
883 }
884 }
885 if (largest > max_deviation || (q > 0 && largest > dev)) {
886 char msg[500];
887 SPRINTF(msg, "Matrix has a numerically zero, leading value at the %d-th pivoted line, but the largest deviation %10e from zero in the rest of the matrix is greater than the tolerance %10e. %.50s.",
888 q,
889 largest,
890 MAX(max_deviation, dev),
891 sp->pivot_check == True
892 ? "If you are sure that the matrix is semi-definite, set 'RFoptions(pivot_check=NA)' or 'RFoptions(pivot_check=True)'"
893 : "The result can be imprecise");
894 if (sp->pivot_check == True) C_GERR(msg, ERR_CHOL)
895 else warn(msg);
896 }
897 }
898 break;
899 }
900 rel_thres += diagonal[pi[q]];
901 int dummy = pi[q];
902 pi[q] = pi[argmax];
903 pi[argmax] = dummy;
596904 }
597905
598
599 double sum = A[i] - scalar(A, A, i);
600 if (sum > 0.0) A[i] = SQRT(sum);
601 else { err = ERRORFAILED; break;}
602 }
603 }
604
605
606
607 if (false) {
608 //braucht 100 % mehr zeit als aufruf von dpotrf
609 // laesst sich nicht ohne weiteres
610 err = NOERROR;
611 // o mp_set_num_threads(Sp->cores);
612 int isize=0;
613 for (int i=0; i<size; i++, isize += size) {
614 double *A = MPT + isize;
615 for (int j=0; j<=i; j++) {
616 int jsize = j * size;
617 double
618 *B = MPT + jsize,
619 sum = A[j];
620 for (int k=0; k<j; k++) sum -= A[k] * B[k];
621 if (j < i) A[j] = sum / B[j];
622 else if (sum > 0.0) A[j] = SQRT(sum);
623 else { err = ERRORFAILED; }
906
907 int pqq = pi[q],
908 col_q = pqq * size;
909
910 if (diagonal[pqq] < 0) {
911 C_GERR1("Negative leading value found at the %d-th pivoted line.",
912 q, ERR_CHOL);
624913 }
625 }
626 }
627
628
629 if (false) {
630 //https://courses.engr.illinois.edu/cs554/fa2013/notes/07_cholesky.pdf
631 // saying that no pivoting necessary. needs 150 % more time
632 err = NOERROR;
633
634 for (int k =0; k<size; k++) {
635 int kspalte = k * size;
636 MPT[k + kspalte] = SQRT(MPT[k + kspalte]);
637 double f = 1.0 / MPT[k + kspalte];
638 for (int i = k + 1; i<size; i++) {
639 int ispalte = i * size;
640 MPT[k + ispalte] *= f;
914 double lqpq = MPT[q + col_q] = SQRT(diagonal[pqq]);
915 #ifdef DO_PARALLEL
916 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(size - q)) schedule(dynamic, 8)
917 #endif
918 for (int i=q+1; i<size; i++) {
919 int
920 pii = pi[i],
921 col_i = pii * size;
922 assert(pii != pqq);
923 double scalar = SCALAR(MPT + col_q, MPT + col_i, q);
924 MPT[q + col_i] = (Morig[pqq + col_i] - scalar) / lqpq;
925 diagonal[pii] -= MPT[q + col_i] * MPT[q + col_i];
926 // in Harbrecht: lqpq * MPT[q + col_i];
641927 }
642 for (int j = k + 1; j<size; j++) {
643 int jspalte = j * size;
644 double factor = MPT[k + jspalte];
645 for (int ispalte=j * size; ispalte<sizeSq; ispalte+=size) {
646 MPT[j + ispalte] -= MPT[k + ispalte] * factor;
928
929 /* if (!true) {
930 for (int k=0; k<size; k++) {
931 for (int j=0; j<size; j++)
932 p rintf("%10g ", MPT[size * j + k]);
933 p rintf("\n");
934 } p rintf("\n");
935 }
936 */
937
938 } // for q
939
940
941 if (err == NOERROR) {
942 if (calculate == MATRIXSQRT) {
943 int i = 0;
944 for ( ; i<actual_size; i++) {
945 FILL_IN(MPT + i + 1 + size * pi[i], size - 1 - i, 0.0);
647946 }
648 }
649 }
650 }
651
652
653 if (err == NOERROR) {
654 if (sqrtOnly) {
655 int deltaend = size - 1;
656 double *end = MPT + sizeSq;
657 for (double *p=MPT + 1; p<end; p+=sizeP1, deltaend--)
658 FILL_IN(p, deltaend, 0.0);
659
660
661
662 /*
663 int deltaend = size;
664 for (int i=0; i<sizeSq; i+=sizeP1) {
665 int end = i + (deltaend--);
666 // printf("%d %d\n", i, end);
667 for (int j=i + 1; j<end; MPT[j++]=0.0); // untere Dreiecksmatrix 0
668 }
669 */
670 } else {
671 int i;
672 if (logdet != NULL) {
673 for (*logdet=0.0, i=0; i < sizeSq; i+=sizeP1) {
674 *logdet += Log(MPT[i]);
947 for ( ; i<size; i++) {
948 FILL_IN(MPT + actual_size + size*pi[i], size - actual_size, 0.0);
675949 }
676 *logdet *= 2;
677 }
678 if (rhs_cols == 0) {
679 long i2, i3, j;
680 F77_CALL(dpotri)("U", &size, MPT, &size, &err);
681 for (i2=i=0; i<size; i++, i2+=size + 1) {
682 for (i3 = i2 + 1, j = i2 + size; j<sizeSq; j+=size)
683 MPT[i3++] = MPT[j];
950
951 } else {
952 if (logdet != NULL) {
953 if (sp->det_as_log) {
954 double logD = 0.0;
955 for (int i=0; i < size; i++) logD += LOG(MPT[i + pi[i] * size]);
956 *logdet = logD * 2;
957 } else {
958 double logD = 1.0;
959 for (int i=0; i < size; i++) logD *= MPT[i + pi[i] * size];
960 *logdet = logD * logD;
961 }
962 if (calculate == DETERMINANT) return NOERROR;
684963 }
685 } else {
686 int totalRHS = size * rhs_cols;
687 if (result != NULL) MEMCOPY(RESULT, rhs, sizeof(double) * totalRHS);
688 F77_CALL(dpotrs)("U", &size, &rhs_cols, MPT, &size, RESULT, &size,
689 &err);
690 }
691 } // sqrt only
692 } // err == NOERROR
964
965 //////////////////////////////////////////////////
966 //////////////////////////////////////////////////
967
968 if (rhs_cols == 0) {
969 if (actual_size < size)
970 GERR("Matrix not definite. Try 'solve(M , diag(nrow(M)))' instead or add a small positive constant to the diagonal.")
971
972 #ifdef DO_PARALLEL
973 #pragma omp parallel for num_threads(CORES) if (size > 60) schedule(dynamic, 20)
974 #endif
975 for (int k=0 ; k<actual_size; k++) {
976 double *p_RESULT = MPT + pi[k] * size + k,
977 diagK = diagonal[k] = 1.0 / p_RESULT[0];
978 for (int i=1; i<size - k; i++) {
979 double *pM = MPT + k + pi[k + i] * size;
980 p_RESULT[i] = (-diagK * pM[0]
981 -SCALAR(pM + 1, p_RESULT + 1, i -1)) / pM[i];
982 }
983 }
984
985
986 #ifdef DO_PARALLEL
987 #pragma omp parallel for num_threads(CORES) if (size > 60) schedule(dynamic, 20)
988 #endif
989 for (int k=0; k<size; k++) {
990 double *p_RESULT = MPT + pi[k] * size;
991 for (int i=actual_size-1; i>k; i--) {
992 double *pM = MPT + pi[i] * size,
993 r = (p_RESULT[i] /= pM[i]);
994 diagonal[k] -= r * pM[k];
995 LINEAR(pM + k + 1, -r, i-k-1, p_RESULT + k + 1);
996 // for (int j=k+1; j<i; j++) p_RESULT[j] -= r * pM[j];
997 }
998 // i == k
999 }
1000
1001 for (int k=0; k<size; k++) {
1002 double *p_RESULT = MPT + pi[k] * size;
1003 for (int q=0; q<k; p_RESULT[q++] = RF_INF);
1004 // for (int q=actual_size; q<size; p_RESULT[q++] = RF_NA);
1005 }
1006
1007 for (int k=0; k<actual_size; k++) {
1008 double *pM = MPT + pi[k] * size;
1009 pM[k] = diagonal[k] / pM[k];
1010 }
1011
1012 CMALLOC(xja, size, int);
1013 Sort(RESULT, size, size, pi, xja, diagonal);
1014 for (int i=0; i<size; i++) {
1015 for (int j=i+1; j<size; j++) {
1016 int idx = i + j * size;
1017 if (MPT[idx] == RF_INF) MPT[idx] = MPT[j + i * size];
1018 else MPT[j + i * size] = MPT[idx];
1019 }
1020 }
1021
1022
1023 //////////////////////////////////////////////////
1024 //////////////////////////////////////////////////
1025
1026 } else { // rhs_cols > 0
1027 assert(rhs != RESULT);
1028 double eps = diagonal[0] * sp->pivot_relerror;
1029
1030 #ifdef DO_PARALLEL
1031 #pragma omp parallel for num_threads(CORES) if (rhs_cols > 30)
1032 #endif
1033 for (int k=0; k<rhs_cols; k++) {
1034 double *p_RESULT = RESULT + k * size,
1035 *p_rhs = rhs + k * size;
1036 int i=0;
1037 for ( ; i<actual_size; i++) {
1038 int pii = pi[i];
1039 double *pM = MPT + pii * size;
1040 p_RESULT[i] = (p_rhs[pii] - SCALAR(pM, p_RESULT, i)) / pM[i];
1041 }
1042 for ( ; i<size; i++) {
1043 int pii = pi[i];
1044 double *pM = MPT + pii * size;
1045 p_RESULT[i] = 0.0;
1046 if (FABS((p_rhs[pii] - SCALAR(pM, p_RESULT, i))) > eps) {
1047 if (Pt == NULL) solve_DELETE(&pt);
1048 ERR1("Equation system not solvable (difference %10e). Try increasing 'pivot_relerror' in 'RFoptions' to get an approximate solution.",
1049 p_rhs[pii] - SCALAR(pM, p_RESULT, i));
1050 }
1051 }
1052 }
1053
1054 #ifdef DO_PARALLEL
1055 #pragma omp parallel for num_threads(CORES) if (rhs_cols > 30)
1056 #endif
1057 for (int k=0; k<rhs_cols; k++) {
1058 double *p_RESULT = RESULT + k * size;
1059 for (int i=actual_size - 1; i>=0; i--) {
1060 int pii = pi[i];
1061 double *pM = MPT + pii * size,
1062 r = (p_RESULT[i] /= pM[i]);
1063 LINEAR(pM, -r, i, p_RESULT);
1064 // for (int j=0; j<i; j++) p_RESULT[j] -= r * pM[j];
1065 }
1066 }
1067 CMALLOC(xja, size, int);
1068 Sort(RESULT, size, rhs_cols, pi, xja, diagonal);
1069 }// rhs_cols > 0
1070 } // not sqrt only
1071
1072 } // err == NOERROR
1073 }
1074
1075 ERR_CHOL:
6931076
6941077 if (err != NOERROR) {
695 CERR1("Cholesky decomposition failed with err=%d. Probably matrix not strictly positive definite.\n", err);
696 }
697
698 if (PL >= PL_DETAILSUSER) PRINTF("Cholesky decomposition successful\n");
1078 if (pt->actual_pivot == PIVOT_NONE)
1079 CERR1("Probably matrix not positive semi definite: %.50s\nTry more flexible options in 'RFoptions' ('pivot = PIVOT_AUTO or 'pivot = PIVOT_DO'').\n", ErrStr)
1080 else // pt->actual_pivot == PIVOT_DO or PIVOT_IDX
1081 CERR1("Likely, the matrix is not positive semi definite: %.50s\n", ErrStr)
1082 }
1083
1084 if (PL >= PL_DETAILSUSER) {
1085 PRINTF("Cholesky decomposition successful\n");
1086 }
6991087
7001088 break;
701
1089 }
7021090 case QR : {// QR returns transposed of the inverse !!
703 if (rhs_cols > 0 || logdet != NULL || !sqrtOnly) {
1091 if (rhs_cols > 0 || logdet != NULL || calculate != SOLVE) {
7041092 err = ERRORFAILED;
7051093 continue;
7061094 }
7111099 CMALLOC(workspaceD, size, double);
7121100 CMALLOC(workspaceU, size, double);
7131101
714 F77_CALL(dgeqrf)(&size, &size,
1102 F77_CALL(dgeqrf)(&size, &size, // QR
7151103 MPT, &size, // aijmax, &irank, inc, workspaceD,
7161104 workspaceU, workspaceD, &size, &err);
7171105
718 //if (GLOBAL.solve.tmp_delete) {FREEING(workspaceD); FREEING(workspaceU);}
719 if (err != NOERROR) {
720 CERR1("'dgeqrf' failed with err=%d\n", err);
721 }
722 if (PL >= PL_DETAILSUSER) PRINTF("QR successful\n");
1106 if (err != NOERROR) {
1107 CERR1("'dgeqrf' failed with err=%d.", err);
1108 }
1109 if (PL >= PL_DETAILSUSER) { PRINTF("QR successful\n"); }
7231110 break;
7241111 }
7251112
7261113 case Eigen : { // M = U D UT
7271114 int max_eigen = sp->max_svd;
7281115 double eigen2zero = sp->eigen2zero;
729 if (size > max_eigen) CERR("matrix too large for eigen value decomposition.");
1116 if (size > max_eigen) CERR("matrix too large for Cholesky or eigen value decomposition. Increase 'max_chol' and 'max_svd' in 'RFoption' if necessary.");
7301117
7311118 double
7321119 optimal_work,
7331120 *pt_work = &optimal_work;
7341121 int k=0,
735 optimal_intwork,
736 *pt_iwork = &optimal_intwork,
737 lwork = -1,
738 lintwork = -1;
1122 optimal_intwork,
1123 *pt_iwork = &optimal_intwork,
1124 lwork = -1,
1125 lintwork = -1;
7391126
7401127 CMALLOC(U, sizeSq, double);
7411128 CMALLOC(D, size, double);
7451132 double dummy = 0.0,
7461133 abstol = 0.0;
7471134 int dummy_nr;
748 // printf("i = %d\n", i);
749
750 F77_CALL(dsyevr)("V", "A", "U", &size, MPT, &size, &dummy, &dummy, &k, &k,
1135
1136 F77_CALL(dsyevr)("V", "A", "U", &size, // Eigen
1137 MPT, &size, &dummy, &dummy, &k, &k,
7511138 &abstol,// or DLAMCH
7521139 &dummy_nr, D, U, &size,
7531140 xja, // 2 * size * sizeof(integer); nonzeros_idx
7551142 pt_iwork, &lintwork,
7561143 &err
7571144 );
758 // printf("i=%d, %d %d size=%d err=%d\n", i, lwork, lintwork, size, err);
7591145 if (i==1 || err != NOERROR || ISNAN(D[0])) break;
7601146 lwork = (int) optimal_work;
7611147 lintwork = (int) optimal_intwork;
7661152 }
7671153
7681154
769 // if (!false) {
770 // int end = MIN(5, size);
771 // for(int ii=0; ii<end; ii++) {
772 // for (int jj=0; jj<end; jj++) printf("%f ", MPT[ii + jj * size]); printf("\n");
773 // }
774 // printf("\n"); for (int ii=0; ii<size; ii++) printf("%e ", D[ii]); printf("\n");
775 // }
776
777
778 if (err != NOERROR) {
779 if (PL>PL_ERRORS)
780 PRINTF("Error code F77_CALL(dsyevr) = %d\n", err);
781 CERR1("'dsyevr' failed with err=%d\n", err);
1155 if (err != NOERROR) {
1156 if (PL>PL_ERRORS) { PRINTF("Error code F77_CALL(dsyevr) = %d\n", err);}
1157 CERR1("'dsyevr' failed with err=%d.", err);
7821158 break;
7831159 }
7841160
7851161 for (int i=0; i<size; i++) if (D[i] < -eigen2zero) {
7861162 const char *advice[2]={"",
787 " Consider increasing the value of 'eigen2value'."};
1163 " Consider increasing the value of 'eigen2value'."};
7881164 double min = D[i];
7891165 for (int j=i+1; j<size; j++) if (D[j] < min) min = D[j];
790 //print("negative eigen values!!!! %f\n", D[i]);
791 GERR3("Negative eigenvalues found (less than -eigen2zero=%e). Smallest one equals %e.%s", -eigen2zero, min, advice[min > -eigen2zero * 100]);
1166 //print("negative eigen values!!!! %10g\n", D[i]);
1167 GERR3("Negative eigenvalues found (less than -eigen2zero=%10e). Smallest one equals %10e. %.50s", -eigen2zero, min, advice[min > -eigen2zero * 100]);
7921168
793 } //else print("%f ", D[i]);
1169 } //else print("%10g ", D[i]);
7941170
795 if (sqrtOnly) {
1171 if (calculate == MATRIXSQRT) {
7961172 for (int j=0; j<size; j++) {
7971173 double dummy;
798 dummy = D[j] < eigen2zero ? 0.0 : SQRT(D[j]);
1174 dummy = 0.0;
1175 if (D[j] >= eigen2zero) dummy = SQRT(D[j]);
7991176 for (int i=0; i<size; i++, k++) RESULT[k] = U[k] * dummy;
8001177 }
8011178 } else {
8021179 // calculate determinant
8031180 if (logdet != NULL) {
804 double dummy = 0.0;
805 for (int i = 0; i < size; dummy += Log(D[i++]));
806 *logdet = dummy;
807 }
808
1181 *logdet = cumProd(D, size, sp->det_as_log);
1182 if (calculate == DETERMINANT) return NOERROR;
1183 }
8091184 for (int j=0; j<size; j++) D[j] = D[j] < eigen2zero ? 0.0 : 1.0 / D[j];
8101185 if (rhs_cols > 0) {
8111186 int tot = size * rhs_cols;
8241199 matmult_2ndtransp(w2, U, RESULT, size, size, size); // V * U^T
8251200 }
8261201 }
827 if (PL >= PL_DETAILSUSER) PRINTF("eigen value decomposition successful\n");
1202 if (PL >= PL_DETAILSUSER) {
1203 PRINTF("eigen value decomposition successful\n");
1204 }
8281205 break;
8291206 }
830
831 case SVD : {// SVD : M = U D VT
832 if (size > sp->max_svd) CERR("matrix too large for SVD decomposition.");
833 int k = 0,
834 lwork = -1,
835 size8 = size * 8;
836 double optim_lwork,
837 eigen2zero = sp->eigen2zero,
838 *pt_work = &optim_lwork;
839
840 CMALLOC(VT, sizeSq, double);
841 CMALLOC(U, sizeSq, double);
842 CMALLOC(D, size, double);
843 CMALLOC(iwork, size8, int);
844
845 for (int i=0; i<=1; i++) {
846 F77_CALL(dgesdd)("A", &size, &size, MPT, &size, D, U, &size, VT, &size,
1207
1208 case SVD : {// SVD : M = U D VT
1209 if (size > sp->max_svd) CERR("matrix too large for SVD decomposition.");
1210 int k = 0,
1211 lwork = -1,
1212 size8 = size * 8;
1213 double optim_lwork,
1214 eigen2zero = sp->eigen2zero,
1215 *pt_work = &optim_lwork;
1216
1217 CMALLOC(VT, sizeSq, double);
1218 CMALLOC(U, sizeSq, double);
1219 CMALLOC(D, size, double);
1220 CMALLOC(iwork, size8, int);
1221
1222 for (int i=0; i<=1; i++) {
1223 F77_CALL(dgesdd)("A", &size, &size, // SVD
1224 MPT, &size, D, U, &size, VT, &size,
8471225 pt_work, &lwork, iwork, &err);
8481226 if (i==1 || err != NOERROR || ISNAN(D[0])) break;
8491227 lwork = (int) optim_lwork;
8501228 CMALLOC(work, lwork, double);
8511229 pt_work = work;
852 }
1230 }
8531231 if (err != NOERROR) {
854 if (PL>PL_ERRORS)
1232 if (PL>PL_ERRORS) {
8551233 PRINTF("Error code F77_CALL(dgesdd) = %d\n", err);
856 CERR1("'dgesdd' failed with err=%d\n", err);
1234 }
1235 CERR1("'dgesdd' failed with err=%d.", err);
8571236 break;
8581237 }
8591238
860 if (sqrtOnly) {
861 double svdtol = sp->svd_tol;
1239 if (calculate == MATRIXSQRT) {
1240 double svdtol = sp->svd_tol;
8621241 /* calculate SQRT of covariance matrix */
8631242 for (int j=0; j<size; j++) {
8641243 double dummy;
865 if (D[j] < -eigen2zero) CERR("negative eigenvalues found");
866 dummy = D[j] < eigen2zero ? 0.0 : SQRT(D[j]);
1244 if (D[j] < -eigen2zero) CERR("negative eigenvalues found.");
1245 dummy = 0.0;
1246 if (D[j] >= eigen2zero) dummy = SQRT(D[j]);
8671247 for (int i=0; i<size; i++, k++) RESULT[k] = U[k] * dummy;
8681248 }
8691249
8731253 for (int i=0; i<size; i++) {
8741254 double *Ui = RESULT + i;
8751255 for (k=i; k<size; k++) {
876 double *Uk = RESULT + k,
1256 double *Uk = RESULT + k,
8771257 sum = 0.0;
878 for (int j=0; j<sizeSq; j+=size) {
879 sum += Ui[j] * Uk[j];
880 }
1258 for (int j=0; j<sizeSq; j+=size) {
1259 sum += Ui[j] * Uk[j];
1260 }
8811261
8821262 if (FABS(Morig[i * size + k] - sum) > svdtol) {
8831263 if (PL > PL_ERRORS) {
884 PRINTF("difference %e at (%d,%d) between the value (%e) of the covariance matrix and the square of its root (%e).\n",
1264 PRINTF("difference %10e at (%d,%d) between the value (%10e) of the covariance matrix and the square of its root (%10e).\n",
8851265 Morig[i * size +k] - sum, i, k, Morig[i*size+k], sum);
8861266 }
887 FERR3("required precision not attained (%e > %e): probably invalid model. See also '%s'\n", FABS(Morig[i * size + k] - sum), svdtol,
1267 FERR3("required precision not attained (%10e > %10e): probably invalid model. See also '%.50s'.", FABS(Morig[i * size + k] - sum), svdtol,
8881268 solve[SOLVE_SVD_TOL]);
8891269
8901270 err=ERRORM;
8911271 break;
892 } //else printf("ok (%d,%d) %f %f\n", i, k, Morig[i*size+k],sum);
1272 } //else printf("ok (%d,%d) %10g %10g\n", i, k, Morig[i*size+k],sum);
8931273 }
8941274 if (err != NOERROR) break;
8951275 }
8961276 if (err != NOERROR) break;
8971277 } // end if svdtol > 0
898
899 } else {
900 // calculate determinant
901 if (logdet != NULL) {
902 double dummy = 0.0;
903 for (int i = 0; i < size; dummy += Log(D[i++]));
904 *logdet = dummy;
905 }
906
907 for (int j=0; j<size; j++)
1278
1279 } else {
1280 // calculate determinant
1281 if (logdet != NULL) {
1282 *logdet = cumProd(D, size, sp->det_as_log);
1283 if (calculate == DETERMINANT) return NOERROR;
1284 }
1285
1286 for (int j=0; j<size; j++)
9081287 D[j] = FABS(D[j]) < eigen2zero ? 0.0 : 1.0 / D[j];
9091288
9101289 if (rhs_cols > 0) {
9251304 }
9261305 }
9271306
928 if (PL >= PL_DETAILSUSER) PRINTF("svd successful\n");
929 // if (GLOBAL.solve.tmp_delete) {FREEING(VT);FREEING(U);FREEING(D);
930 //FREEING_INT(iwork);FREEING(work);FREEING(w2);}
1307 if (PL >= PL_DETAILSUSER) { PRINTF("svd successful\n"); }
9311308 break;
932 }
1309 }
9331310
9341311 case LU : {// LU
935 if (!sqrtOnly) {
1312 if (calculate == MATRIXSQRT) {
9361313 err = ERRORFAILED;
9371314 continue;
9381315 }
9391316
9401317 CMALLOC(ipiv, size, int);
941 F77_CALL(dgetrf)(&size, &size, MPT, &size, ipiv, &err);
1318 F77_CALL(dgetrf)(&size, &size, // LU
1319 MPT, &size, ipiv, &err);
9421320 if (err != NOERROR) {
943 CERR1("'dgetrf' (LU) failed with err=%d\n", err);
1321 CERR1("'dgetrf' (LU) failed with err=%d.", err);
9441322 }
9451323
9461324 if (logdet != NULL) {
947 CERR("logdet cannot be determined for 'LU'");
948 int i;
949 for (*logdet=0.0, i = 0; i < sizeSq; i += sizeP1) *logdet +=Log(MPT[i]);
1325 CERR("logdet cannot be determined for 'LU'.");
1326 *logdet = Determinant(MPT, size, sp->det_as_log);
1327 if (calculate == DETERMINANT) return NOERROR;
9501328 }
9511329
9521330 if (rhs_cols > 0) {
9531331 int totalRHS = size * rhs_cols;
9541332 if (result != NULL) MEMCOPY(RESULT, rhs, sizeof(double) * totalRHS);
955 F77_CALL(dgetrs)("N", &size, &rhs_cols, MPT, &size, ipiv,
1333 F77_CALL(dgetrs)("N", &size, // LU rhs
1334 &rhs_cols, MPT, &size, ipiv,
9561335 RESULT, &size, &err);
9571336 if (err != NOERROR) {
958 CERR1("'dgetrs' (LU) failed with err=%d\n", err);
1337 CERR1("'dgetrs' (LU) failed with err=%d.", err);
9591338 }
9601339 } else {
9611340 int lwork = -1;
9621341 double dummy,
9631342 *p = &dummy;
9641343 for (int i=0; i<=1; i++) {
965 F77_CALL(dgetri)(&size, MPT, &size, ipiv, p, &lwork, &err);
1344 F77_CALL(dgetri)(&size, MPT, // LU solve
1345 &size, ipiv, p, &lwork, &err);
9661346 if (err != NOERROR) break;
9671347 lwork = (int) dummy;
9681348 CMALLOC(workLU, lwork, double);
9691349 p = workLU;
9701350 }
9711351 }
972 if (PL >= PL_DETAILSUSER) PRINTF("LU decomposition successful\n");
973 //if (GLOBAL.solve.tmp_delete) {FREEING_INT(ipiv);FREEING(workLU);}
1352 if (PL >= PL_DETAILSUSER) { PRINTF("LU decomposition successful\n"); }
9741353 break;
9751354 }
9761355
9771356 case Sparse : {// sparse matrix
978 int nnzlindx,
979 doperm = sp->pivot,
980 halfsq = size * (size + 1) / 2,
981 nnzcolindices = 0,
982 nnzR = 0,
983 cache = 512, // to do: CPU cache size
984 nnzcfact[3] = { 5, 1, 5 },
985 nnzRfact[3] = { 5, 1, 2 };
986 double
987 cholincrease_nnzcol = 1.25,
988 cholincrease_nnzR = 1.25;
989
990 if (!posdef) CERR("'spam' needs a positive definite matrix");
991 CMALLOC(pivot, size, int);
992 if (!doperm) for (int i=0; i<size; i++) pivot[i] = i + 1;
1357 int nnzlindx,
1358 doperm = sp->pivotsparse,
1359 halfsq = size * (size + 1) / 2,
1360 nnzcolindices = 0,
1361 nnzR = 0,
1362 cache = 512, // to do: CPU cache size
1363 nnzcfact[3] = { 5, 1, 5 },
1364 nnzRfact[3] = { 5, 1, 2 };
1365 double
1366 cholincrease_nnzcol = 1.25,
1367 cholincrease_nnzR = 1.25;
1368
1369 if (!posdef) CERR("'spam' needs a positive definite matrix.");
1370 CMALLOC(pivotsparse, size, int);
1371 if (!doperm) for (int i=0; i<size; i++) pivotsparse[i] = i + 1;
9931372
9941373 if (spam_zaehler == 0) {
9951374 for (int i=0; i<sizeSq; i++) nnzA += FABS(M[i]) >= spam_tol;
10091388 int nDD = spam_zaehler;
10101389 if (nDD < size) nDD = size;
10111390 CMALLOC(DD, nDD, double);
1012 // prepare spam
1391 // prepare spam
10131392
10141393 F77_CALL(spamdnscsr)(&size, &size, M, &size, DD,
10151394 cols, // ja
10161395 rows, // ia
10171396 &spam_tol); // create spam object
10181397 pt->nsuper = 0;
1019 // calculate spam_cholesky
1398 // calculate spam_cholesky
10201399 err = 4; // to get into the while loop
10211400 while (err == 4 || err == 5) {
10221401 if (nnzcolindices == 0) {
10311410 if (nnzcolindices < nnzA) nnzcolindices = nnzA;
10321411 } else if (err == 5) {
10331412 int tmp = (int) CEIL(nnzcolindices * cholincrease_nnzcol);
1034 if (PL > PL_RECURSIVE)
1413 if (PL > PL_RECURSIVE) {
10351414 PRINTF("Increased 'nnzcolindices' with 'NgPeyton' method\n(currently set to %d from %d)", tmp, nnzR);
1415 }
10361416 nnzcolindices = tmp;
10371417 }
10381418 if (nnzcolindices < pt->lindx_n) nnzcolindices = pt->lindx_n;
10431423 nnzR = (int) u * nnzRfact[doperm];
10441424 } else if (err == 4) {
10451425 int tmp = (int) CEIL(nnzR * cholincrease_nnzR);
1046 if (PL > PL_RECURSIVE)
1426 if (PL > PL_RECURSIVE) {
10471427 PRINTF("Increased 'nnzR' with 'NgPeyton' method\n(currently set to %d from %d)", tmp, nnzR);
1428 }
10481429 nnzR = tmp;
10491430 }
10501431 if (nnzR < pt->lnz_n) nnzR = pt->lnz_n;
10541435 CMALLOC(lnz, nnzR, double);
10551436
10561437 F77_CALL(cholstepwise)(&size, &nnzA, DD, cols, rows, &doperm,
1057 invp, pivot,
1438 invp, pivotsparse,
10581439 &nnzlindx, &nnzcolindices,
10591440 lindx, //
10601441 xlindx,//
10691450 );
10701451
10711452 if (err != NOERROR) {
1072 CERR1("'cholstepwise' failed with err=%d\n", err);
1453 CERR1("'cholstepwise' failed with err=%d.", err);
10731454 break;
10741455 }
10751456 } // while
10761457
1077 if (err != NOERROR) CERR("'spam' failed");
1078 if (PL >= PL_DETAILSUSER) PRINTF("'spam' successful\n");
1458 if (err != NOERROR) CERR("'spam' failed.");
1459 if (PL >= PL_DETAILSUSER) { PRINTF("'spam' successful\n"); }
10791460
10801461 // spam solve
10811462
1082 if (sqrtOnly) {
1463 if (calculate == MATRIXSQRT) {
10831464
10841465 //BUG; // unexpected behaviour in spam
10851466
10931474 int endfor = (i + 1) * size;
10941475 for (int j = i * (size + 1) + 1; j<endfor; RESULT[j++]=0.0);
10951476 }
1096 //if (GLOBAL.solve.tmp_delete) {FREEING_INT(pivot); FREEING_INT(xlnz);
1097 //FREEING_INT(snode); FREEING_INT(xsuper); FREEING_INT(xlindx);
1098 //FREEING_INT(invp);FREEING(w3);FREEING_INT(cols);FREEING_INT(rows);
1099 //FREEING(DD);FREEING_INT(lindx);FREEING(lnz);FREEING_INT(xja);}
11001477 } else {
11011478 double *lnz = pt->lnz;
11021479 int RHS_COLS,
11041481
11051482 // spam determinant
11061483 if (logdet != NULL) {
1107 double tmp = 0.0;
1108 for (int i=0; i<size; i++) {
1109 tmp += Log(lnz[xlnz[i] - 1]);
1484 if (sp->det_as_log) {
1485 double tmp = 0.0;
1486 for (int i=0; i<size; i++) tmp += LOG(lnz[xlnz[i] - 1]);
1487 *logdet = 2.0 * tmp;
1488 } else {
1489 double tmp = 1.0;
1490 for (int i=0; i<size; i++) tmp *= lnz[xlnz[i] - 1] ;
1491 *logdet = tmp * tmp;
11101492 }
1111 *logdet = 2.0 * tmp;
1493 if (calculate == DETERMINANT) return NOERROR;
11121494 }
11131495
11141496 /* z = .Fortran("backsolves", m = nrow,
11331515
11341516 //printf("nsuper=%d\n", pt->nsuper);
11351517 // for (int ii=0; ii<size; ii++)
1136 //printf("%d %d %d %d %e\n", ii, pt->nsuper, sizeP1, xsuper[ii],
1518 //printf("%d %d %d %d %10e\n", ii, pt->nsuper, sizeP1, xsuper[ii],
11371519 // w3[ii]);
11381520
11391521 // if (false)
11421524 // Lj = xsuper[jsub + 1 - 1] -1;
11431525 // printf("%d %d %d\n", jsub, fj, Lj);
11441526 // for (int jcol=fj; jcol <= Lj; jcol++) {
1145 // printf("%d,%f ", jcol, w3[jcol - 1]);
1527 // printf("%d,%10g ", jcol, w3[jcol - 1]);
11461528 // }
11471529 // }
11481530
11491531 // for (int jcol=1; jcol <= 600; jcol++) {
11501532 // w3[jcol - 1] = jcol;
1151 // printf("%d,%f ", jcol, w3[jcol - 1]);
1533 // printf("%d,%10g ", jcol, w3[jcol - 1]);
11521534 // }
11531535
11541536
11551537 // printf("%ld %ld %d\n", RESULT, rhs, rhs_cols);
1156 // for (int ii=0; ii<size; ii++) printf("%d %e\n", ii, RESULT[ii]);
1538 // for (int ii=0; ii<size; ii++) printf("%d %10e\n", ii, RESULT[ii]);
11571539 // BUG;
11581540
11591541 F77_CALL(backsolves)(&size, &(pt->nsuper), &RHS_COLS,
11611543 xlindx, //colpointers
11621544 lnz,
11631545 xlnz, // rowpointers
1164 invp, pivot,
1546 invp, pivotsparse,
11651547 xsuper, // supernodes
11661548 w3, RESULT);
1167 if (PL >= PL_DETAILSUSER) PRINTF("'spam' successful\n");
1168 //if (GLOBAL.solve.tmp_delete) {FREEING_INT(pivot);FREEING_INT(xlnz);
1169 //FREEING_INT(snode);FREEING_INT(xsuper);FREEING_INT(xlindx);
1170 //FREEING_INT(invp);FREEING(w3);FREEING_INT(cols);FREEING_INT(rows);
1171 //FREEING(DD);FREEING_INT(lindx);FREEING(lnz);FREEING_INT(xja);}
1172 }
1173
1549 if (PL >= PL_DETAILSUSER) { PRINTF("'spam' successful\n"); }
1550 }
11741551 break;
11751552 } // Sparse
1176
1177 default : BUG;
1178 GERR("unknown method in 'RandomFieldsUtils'");
1179
1553
1554 case NoInversionMethod: GERR("no inversion method given.");
1555 case NoFurtherInversionMethod:
1556 #ifdef DO_PARALLEL
1557 GERR("All specified matrix inversion methods have failed.");
1558 #else
1559 STRCPY(ErrStr, ERRORSTRING);
1560 GERR1("%.50s (All specified matrix inversion methods have failed.)",
1561 ErrStr);
1562 #endif
1563 case direct_formula: case Diagonal:
1564 GERR("strange method appeared: please contact author.");
1565 default : GERR1("unknown method (%d) in 'RandomFieldsUtils'.", pt->method);
11801566 } // switch
1181
1567
11821568 if (err==NOERROR) break;
11831569 } // for m
11841570
1185
1571
11861572 ErrorHandling:
1573 if (Pt == NULL) {
1574 solve_DELETE(&pt);
1575 } else {
1576 Pt->sparse = sparse;
1577 }
11871578
1188 if (Pt == NULL) solve_DELETE(&pt);
1189 //else if (GLOBAL.solve.tmp_delete) {FREEING(SICH); FREEING(MM);}
11901579
11911580 return err; // -method;
11921581 }
11931582
11941583
1195 SEXP doPosDef(SEXP M, SEXP rhs, SEXP logdet, bool sqrtOnly,
1196 solve_param *Sp){
1584 SEXP doPosDef(SEXP M, SEXP rhs, SEXP logdet, int calculate,
1585 solve_storage *Pt, solve_param *Sp){
11971586 int
11981587 rhs_rows, rhs_cols,
11991588 err = NOERROR,
12021591 bool deleteMM = false,
12031592 deleteRHS = false;
12041593 SEXP res;
1594 solve_storage Pt0, *pt = Pt;
1595 if (pt == NULL) {
1596 solve_NULL(&Pt0);
1597 pt = &Pt0;
1598 }
12051599
12061600
12071601 if (rhs == R_NilValue) {
12271621 if (rhs_cols==0 || isMatrix(rhs)) {
12281622 res = PROTECT(allocMatrix(REALSXP, size, new_cols));
12291623 } else {
1230 res = PROTECT(allocVector(REALSXP, total));
1624 res = PROTECT(allocVector(REALSXP, total));
12311625 }
12321626
12331627
12701664 (rhs_cols == 0 && TYPEOF(M) == REALSXP) ||
12711665 (rhs_cols > 0 && TYPEOF(rhs) == REALSXP) ? REAL(res) : NULL,
12721666 length(logdet) == 0 ? NULL : REAL(logdet),
1273 sqrtOnly, NULL, Sp);
1667 calculate, pt, Sp);
12741668
12751669 ErrorHandling:
12761670 if (deleteMM) FREE(MM);
12771671 if (deleteRHS) FREE(RHS);
1672 if (pt != Pt) solve_DELETE0(pt);
12781673
12791674 UNPROTECT(1);
12801675 if (err != NOERROR) {
1281 const char *methname[] = {"solvePosDef", "cholesky"};
1282 if (err != ERRORM) strcpy(ERRORSTRING, "");
1283 ERR2("'%s' failed: %s\n", methname[sqrtOnly], ERRORSTRING);
1676 const char *methname[] = {"solvePosDef", "cholesky", "determinant"};
1677 errorstring_type msg;
1678 switch (err) {
1679 case ERRORMEMORYALLOCATION : STRCPY(msg, "memory allocation error"); break;
1680 case ERRORNOTPROGRAMMEDYET : STRCPY(msg, "not programmed yet"); break;
1681 case ERRORFAILED : STRCPY(msg, "algorithm has failed"); break;
1682 case ERRORM : STRCPY(msg, pt->err_msg);
1683 break;
1684 default: STRCPY(msg, "<unknown error>");
1685 }
1686 RFERROR2("'%.50s': %.50s.\n", methname[calculate], msg);
12841687 }
12851688
12861689 return res;
12881691
12891692
12901693 SEXP SolvePosDef(SEXP M, SEXP rhs, SEXP logdet){
1291 return doPosDef(M, rhs, logdet, false, &(GLOBAL.solve));
1292 }
1694 return doPosDef(M, rhs, logdet, SOLVE, NULL, &(GLOBAL.solve));
1695 }
1696
12931697
12941698 int solvePosDefResult(double *M, int size, bool posdef,
12951699 double *rhs, int rhs_cols, double *result,
12961700 double *logdet, solve_storage *PT) {
1297 return doPosDef(M, size, posdef, rhs, rhs_cols, result, logdet, false,
1298 PT, &(GLOBAL.solve));
1299 }
1701 return doPosDef(M, size, posdef, rhs, rhs_cols, result, logdet, SOLVE,
1702 PT, &(GLOBAL.solve));
1703 }
1704
13001705
13011706 int solvePosDef(double *M, int size, bool posdef,
1302 double *rhs, int rhs_cols,
1303 double *logdet,
1304 solve_storage *PT) {
1305 return doPosDef(M, size, posdef, rhs, rhs_cols, NULL, logdet, false,
1707 double *rhs, int rhs_cols,
1708 double *logdet,
1709 solve_storage *PT) {
1710 return doPosDef(M, size, posdef, rhs, rhs_cols, NULL, logdet, SOLVE,
13061711 PT, &(GLOBAL.solve));
13071712 }
13081713
13091714
1715
1716 int XCinvYdet(double *M, int size, bool posdef, double *X, double *Y, int cols,
1717 double *XCinvY, double *det, bool log, solve_storage *PT) {
1718 int NR = KAHAN ? SCALAR_KAHAN : SCALAR_AVX;
1719 bool pt = PT != NULL && PT->result != NULL;
1720 double *result;
1721 if (pt) result=PT->result;
1722 else result= (double *) MALLOC(sizeof(double) * size * cols);
1723 if (result == NULL) return ERRORMEMORYALLOCATION;
1724 double *res = result;
1725 solve_param sp = GLOBAL.solve;
1726 sp.det_as_log = log;
1727 int err = doPosDef(M, size, posdef, Y, cols, result, det, SOLVE, PT, &sp);
1728 for (int i=0; i<cols; i++, res += size, X += size)
1729 XCinvY[i] = SCALAR(res, X, size);
1730 if (!pt) FREE(result);
1731 return err;
1732 }
1733
1734 int XCinvXdet(double *M, int size, double *X, int X_cols,
1735 double *XCinvX, double *det, bool log, solve_storage *PT) {
1736 return XCinvYdet(M, size, true, X, X, X_cols, XCinvX, det, log, PT);
1737 }
1738
1739
1740 double XCinvXlogdet(double *M, int size, double *X, int X_cols,
1741 solve_storage *PT) {
1742 int NR = KAHAN ? SCALAR_KAHAN : SCALAR_AVX;
1743 bool pt = PT != NULL && PT->result != NULL;
1744 double ans, *result;
1745 if (pt) result = PT->result;
1746 else result = (double *) MALLOC(sizeof(double) * size * X_cols);
1747 if (result == NULL) ERR("memory allocation error in 'xcxlogdet'");
1748 double *res = result;
1749 solve_param sp = GLOBAL.solve;
1750 sp.det_as_log = true;
1751 int err = doPosDef(M, size, true, X, X_cols, result, &ans, SOLVE, PT, &sp);
1752 ans *= X_cols;
1753 for (int i=0; i<X_cols; i++, res += size, X += size) {
1754 ans += SCALAR(res, X, size);
1755 }
1756 if (!pt) FREE(result);
1757 if (err != NOERROR)
1758 ERR("error occurred when calculating determinant of a pos def matrix.");
1759 return ans;
1760 }
1761
1762
1763 double detPosDef(double *M, int size) {//never log of det --always small sizes!!
1764 solve_param sp = GLOBAL.solve;
1765 sp.det_as_log = false;
1766 double det;
1767 int err= doPosDef(M, size, true, NULL, 0, NULL, &det, DETERMINANT, NULL, &sp);
1768 if (err != NOERROR)
1769 ERR("error occurred when calculating determinant of a pos def matrix.");
1770 return det;
1771 }
1772
1773
13101774 int invertMatrix(double *M, int size) {
1311 solve_storage *pt = (solve_storage*) MALLOC(sizeof(solve_storage));
1312 int err;
1313 // to do
1314 err = doPosDef(M, size, false, NULL, 0, NULL, NULL, false,
1315 pt, &(GLOBAL.solve));
1316 solve_DELETE(&pt);
1317 return err;
1318 }
1319
1320
1321
1775 return doPosDef(M, size, false, NULL, 0, NULL, NULL, SOLVE, NULL, NULL);
1776 }
1777
1778
1779
1780 SEXP Chol(SEXP M) {
1781 solve_param sp = GLOBAL.solve;
1782 sp.Methods[0] = sp.Methods[1] = Cholesky;
1783 sp.sparse = False; // currently does not work, waiting for Reinhard
1784 // sp.pivot = PIVOT_NONE;
1785 solve_storage Pt;
1786 solve_NULL(&Pt);
1787 SEXP Ans;
1788 PROTECT(Ans = doPosDef(M, R_NilValue, R_NilValue, MATRIXSQRT, &Pt, &sp));
1789
1790 if (Pt.actual_pivot == PIVOT_DO || Pt.actual_pivot == PIVOT_IDX) {
1791 // NEVER: FREE(GLOBAL.solve.pivot_idx); See Pivot_Cholesky:
1792 SEXP Idx, Info1, Info3;
1793 PROTECT(Idx = allocVector(INTSXP, Pt.pivot_idx_n));
1794 MEMCOPY(INTEGER(Idx), Pt.pivot_idx, sizeof(int) * Pt.pivot_idx_n);
1795 setAttrib(Ans, install("pivot_idx"), Idx);
1796
1797 PROTECT(Info1 = allocVector(INTSXP, 1));
1798 INTEGER(Info1)[0] = Pt.actual_size;
1799 setAttrib(Ans, install("pivot_actual_size"), Info1);
1800
1801 PROTECT(Info3 = allocVector(INTSXP, 1));
1802 INTEGER(Info3)[0] = PIVOT_DO;
1803 setAttrib(Ans, install("actual_pivot"), Info3);
1804
1805 UNPROTECT(3);
1806 assert(Pt.pivot_idx_n == ncols(M));
1807 }
1808
1809 solve_DELETE0(&Pt);
1810 UNPROTECT(1);
1811 return Ans;
1812 }
1813
1814
1815 int chol(double *M, int size) {
1816 solve_param sp = GLOBAL.solve;
1817 sp.Methods[0] = sp.Methods[1] = Cholesky;
1818 sp.sparse = False; // currently does not work, waiting for Reinhard
1819 sp.pivot = PIVOT_NONE;
1820 return doPosDef(M, size, true, NULL, 0, NULL, NULL, MATRIXSQRT, NULL, &sp);
1821 }
1822
1823
1824 bool is_positive_definite(double *C, int dim) { // bool not allowed in C
1825 int err,
1826 bytes = sizeof(double) * dim * dim;
1827 double *test;
1828 test = (double*) MALLOC(bytes);
1829 MEMCOPY(test, C, bytes);
1830 err = chol(test, dim);
1831 UNCONDFREE(test);
1832 return(err == NOERROR);
1833 }
13221834
13231835
13241836
13251837 /*
13261838
1327 ## extrem wichter check -- folgendes funktioniert bislang bei spam nicht:
1328 library(RandomFields, lib="~/TMP")
1329 RFoptions(printlevel = 3, pch="", seed=999, use_spam = TRUE)
1330 z = RFsimulate(RMspheric(), x, max_variab=10000, n=10000, spC=FALSE)
1331 C = cov(t(z))
1332 c = RFcovmatrix(RMspheric(), x)
1333 print(summary(as.double(c - C))) ##//
1334 stopifnot(max(a b s(c-C)) < 0.05)
1335
1336 */
1337
1338
1339 int sqrtPosDef(double *M, int size, // in out
1340 solve_storage *pt // in out
1341 ){
1839 ## extrem wichter check -- folgendes funktioniert bislang bei spam nicht:
1840 library(RandomFields, lib="~/TMP")
1841 RFoptions(printlevel = 3, pch="", seed=999, use_spam = TRUE) #//
1842 z = RFsimulate(RMspheric(), x, max_variab=10000, n=10000, spC=F ALSE)
1843 C = cov(t(z))
1844 c = RFcovmatrix(RMspheric(), x) #//
1845 p rint(summary(as.double(c - C))) ##//
1846 stopifnot(max(a b s(c-C)) < 0.05)
1847
1848 */
1849
1850
1851 int sqrtPosDefFree(double *M, // in out
1852 int size,
1853 solve_storage *pt, // in out
1854 solve_param *sp
1855 ){
13421856 int err, sizeSq = size * size;
1343 // InversionMethod Methods[SOLVE_METHODS] = { GLOBAL.solve.Methods[0],
1344 // GLOBAL.solve.Methods[1] };
1345 // GLOBAL.solve.Methods[0] = GLOBAL.solve.Methods[1] =
1346
1347 if (GLOBAL.solve.sparse == True)
1857 if (sp == NULL) sp = &(GLOBAL.solve);
1858 InversionMethod *Meth = sp->Methods;
1859 double *res = NULL;
1860 bool extra_alloc = Meth[0] == NoInversionMethod ||
1861 Meth[0] == NoFurtherInversionMethod ||
1862 (Meth[1] != NoInversionMethod && Meth[1] != NoFurtherInversionMethod &&
1863 Meth[1] != Meth[0]) ||
1864 (Meth[0] != Cholesky && Meth[0] != Eigen && Meth[0] != SVD);
1865 assert(pt != NULL);
1866
1867 if (sp->sparse == True)
13481868 warning("package 'spam' is currently not used for simulation");
1349 usr_bool sparse = GLOBAL.solve.sparse;
1350 GLOBAL.solve.sparse = False;
1351 assert(pt != NULL);
1352 CMALLOC(result, sizeSq, double);
1353 err = doPosDef(M, size, true, NULL, 0, result, NULL, true, pt,
1354 &(GLOBAL.solve));
1355 GLOBAL.solve.sparse = sparse;
1356 return err;
1357 }
1358
1359 int sqrtPosDefFree(double *M, int size, // in out
1360 solve_storage *pt // in out
1361 ){
1362 int err, sizeSq = size * size;
1363 solve_param *sp = &(GLOBAL.solve);
1364 InversionMethod *Meth = sp->Methods;
1365
1366 if (Meth[0] == NoInversionMethod || Meth[0] == NoFurtherInversionMethod ||
1367 (Meth[1] != NoInversionMethod && Meth[1] != NoFurtherInversionMethod &&
1368 Meth[1] != Meth[0]) ||
1369 (Meth[0] != Cholesky && Meth[0] != Eigen && Meth[0] != SVD)
1370 ) {
1371 err = sqrtPosDef(M, size, pt);
1869 sp->sparse = False;
1870
1871 if (extra_alloc) {
1872 CMALLOC(result, sizeSq, double);
1873 res = result;
1874 } else {
1875 FREE(pt->result);
1876 pt->result = M;
1877 pt->result_n = sizeSq;
1878 }
1879
1880
1881 // printf("%ld %d %ld %d %ld %ld\n", M, size, res, MATRIXSQRT, pt, sp);
1882
1883 // it is ok to have
1884 // ==15170== Syscall param sched_setaffinity(mask) points to unaddressable byte(s)
1885 // caused by gcc stuff
1886 err = doPosDef(M, size, true, NULL, 0, res, NULL, MATRIXSQRT, pt, sp);
1887 if (extra_alloc) {
13721888 #ifdef WIN32
13731889 pt->to_be_deleted = M;
13741890 #else
1375 Free(M);
1891 Free(M);
13761892 #endif
1377 return(err);
1378 }
1379
1380 if (GLOBAL.solve.sparse == True)
1381 warning("package 'spam' is currently not used for simulation");
1382 usr_bool sparse = GLOBAL.solve.sparse;
1383 GLOBAL.solve.sparse = False;
1384 assert(pt != NULL);
1385 FREE(pt->result);
1386 pt->result = M;
1387 pt->result_n = sizeSq;
1388 err = doPosDef(M, size, true, NULL, 0, NULL, NULL, true, pt, sp);
1389
1390 //int doPosDef(double *M, int size, bool posdef,
1391 // double *rhs, int rhs_cols, double *result, double *logdet,
1392 // bool sqrtOnly, solve_storage *Pt, solve_param *Sp
1393 GLOBAL.solve.sparse = sparse;
1893 }
13941894 return err;
13951895 }
13961896
1397 SEXP Chol(SEXP M) {
1398 solve_param chol_param = GLOBAL.solve;
1399 chol_param.Methods[0] = chol_param.Methods[1] = Cholesky;
1400 chol_param.sparse = False; // currently does not work, waiting for Reinhard
1401 chol_param.pivot = PIVOT_NONE;
1402 return doPosDef(M, R_NilValue, R_NilValue, true, &chol_param);
1403 }
1897
1898 void sqrtRHS_Chol(double *U, int size, double* RHS, int RHS_size, int n,
1899 double *result,
1900 bool pivot, int act_size, int *pi) {
1901 // printf("n=%d,rhss=%d si=%d pivot=%d, act=%d U=%d RHS=%d %d pi=%d\n",
1902 // n, RHS_size, size,pivot, act_size, U!=NULL, RHS!=NULL, result!=NULL, pi!=NULL );
1903 // for (int i=0; i<size; i++) printf("%d ", pi[i]); printf("\n");
1904
1905 int
1906 nsize = n * size,
1907 NR = KAHAN ? SCALAR_KAHAN : SCALAR_AVX;
1908 assert(U != NULL);
1909 if (pivot){
1910 int n_act_size = n * act_size,
1911 diff = size - act_size,
1912 n_diff = nsize - n_act_size;
1913 #ifdef DO_PARALLEL
1914 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(n_act_size)) schedule(dynamic, 8)
1915 #endif
1916 for (int i=0 ; i<n_act_size; i++) {
1917 int ii = i % act_size,
1918 j = i / act_size;
1919 result[pi[ii] + j * size] = SCALAR(RHS + j * RHS_size, U + pi[ii] * size,
1920 ii + 1);
1921 }
1922 pi += act_size;
1923 #ifdef DO_PARALLEL
1924 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(n_diff))
1925 #endif
1926 for (int i=0; i<n_diff; i++) {
1927 int ii = pi[i % diff],
1928 j = i / diff;
1929 result[ii + j * size] = SCALAR(RHS + j * RHS_size, U + ii*size, act_size);
1930 }
1931 } else {
1932 #ifdef DO_PARALLEL
1933 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(nsize)) schedule(dynamic, 8)
1934 #endif
1935 for (int i=0; i<nsize; i++) {
1936 int ii = i % size,
1937 j = (i / size) * size;
1938 result[ii + j] = SCALAR(RHS + j, U + ii * size, ii + 1);
1939 }
1940 }
1941 }
1942
1943 SEXP tcholRHS(SEXP C, SEXP RHS) {
1944 int n_protect = 2;
1945 SEXP Ans, Idx;
1946 PROTECT(Idx = getAttrib(C, install("pivot_idx")));
1947 bool pivot = length(Idx) > 0;
1948 int
1949 n = isMatrix(RHS) ? ncols(RHS) : 1,
1950 rows = isMatrix(RHS) ? nrows(RHS) : length(RHS),
1951 size = ncols(C),
1952 act_size =size;
1953 if (pivot) {
1954 SEXP dummy;
1955 PROTECT(dummy = getAttrib(C, install("pivot_actual_size")));
1956 act_size=INTEGER(dummy)[0];
1957 n_protect++;
1958 }
1959 int *pi = pivot ? (int *) INTEGER(Idx) : NULL;
1960 if (isMatrix(RHS)) PROTECT(Ans = allocMatrix(REALSXP, size, n));
1961 else PROTECT(Ans = allocVector(REALSXP, size));
1962 if (rows < act_size) ERR("too few rows of RHS");
1963 sqrtRHS_Chol(REAL(C), size, REAL(RHS), rows, n, REAL(Ans),
1964 pivot, act_size, pi);
1965 UNPROTECT(n_protect);
1966 return Ans;
1967 }
1968
1969
1970 SEXP chol2mv(SEXP C, SEXP N) {
1971 int n_protect = 2;
1972 SEXP Ans, Idx;
1973 PROTECT(Idx= getAttrib(C, install("pivot_idx")));
1974 bool pivot = length(Idx) > 0;
1975 int
1976 n = INTEGER(N)[0],
1977 size = ncols(C),
1978 act_size = size;
1979 if (pivot) {
1980 SEXP dummy;
1981 PROTECT(dummy = getAttrib(C, install("pivot_actual_size")));
1982 act_size = INTEGER(dummy)[0];
1983 n_protect++;
1984 }
1985 int
1986 n_act_size = n * act_size,
1987 *pi = pivot ? INTEGER(Idx) : NULL;
1988 if (n == 1) PROTECT(Ans = allocVector(REALSXP, size));
1989 else PROTECT(Ans = allocMatrix(REALSXP, size, n));
1990 double *gauss = (double *) MALLOC(sizeof(double) * n_act_size);
1991 if (gauss == NULL) ERR("memory allocation error");
1992 GetRNGstate();
1993 for (int i=0; i<n_act_size; gauss[i++] = GAUSS_RANDOM(1.0));
1994 PutRNGstate();
1995 sqrtRHS_Chol(REAL(C), size, gauss, act_size, n, REAL(Ans),
1996 pivot, act_size, pi);
1997 FREE(gauss);
1998 UNPROTECT(n_protect);
1999 return Ans;
2000 }
2001
14042002
14052003 int sqrtRHS(solve_storage *pt, double* RHS, double *result){
14062004 assert(pt != NULL);
14072005 int
14082006 size = pt->size;
1409
14102007 switch (pt->method) {
14112008 case direct_formula :
14122009 case Cholesky : {
1413 double *U = pt->result;
1414 assert(U != NULL);
1415 #ifdef DO_PARALLEL
1416 #pragma omp parallel for schedule(dynamic) if (MULTIMINSIZE(size))
1417 #endif
1418 for (int i=0; i<size; i++) {
1419 double dummy,
1420 *Uk = U + i * size;
1421 int iP1 = i + 1;
1422 SCALAR_PROD(RHS, Uk, iP1, dummy);
1423 // printf("%d %f\n", i, dummy);
1424 result[i] = dummy;
1425 }
1426 }
1427 break;
1428
2010 bool pivot = (pt->actual_pivot == PIVOT_DO ||
2011 pt->actual_pivot == PIVOT_IDX) &&
2012 pt->method != direct_formula;
2013 if (pivot && pt->pivot_idx_n != size) BUG;
2014
2015 sqrtRHS_Chol(pt->result, size, RHS, size, 1, result, pivot,
2016 pivot ? pt->actual_size : NA_INTEGER,
2017 pt->pivot_idx);
2018 return NOERROR;
2019 }
14292020 case SVD : case Eigen : {
14302021 double *U = pt->result;
14312022 assert(U != NULL);
14322023 #ifdef DO_PARALLEL
1433 #pragma omp parallel for if (MULTIMINSIZE(size))
2024 #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(size))
14342025 #endif
14352026 for (int i=0; i<size; i++){
14362027 double dummy = 0.0;
14412032 }
14422033 break;
14432034
1444
14452035 case Sparse : {
1446 BUG; // SEE ALSO solve, sqrtOnly, tmp_delete !!
2036 BUG; // SEE ALSO solve, calculate, tmp_delete !!
14472037 int one = 1;
14482038 assert(pt->DD != NULL);
1449 F77_CALL(amuxmat)(&size, &size, &one, RHS, pt->DD, pt->lnz,
2039 F77_CALL(amuxmat)(&size, &size, &one, RHS, pt->DD, pt->lnz,
14502040 pt->xja, pt->xlnz);
14512041 for (int i=0; i<size; i++) result[i] = pt->DD[pt->invp[i]];
14522042 }
14602050 for (i=j=0; j<size; j++, i+=sizeP1) result[j] = RHS[j] * D[i];
14612051 }
14622052 break;
2053
14632054 default :
14642055 BUG;
14652056 }
14662057
14672058 return NOERROR;
14682059 }
2060
0 /*
1 Authors
2 Martin Schlather, schlather@math.uni-mannheim.de
3
4 Copyright (C) 2017 -- 2017 Martin Schlather
5
6 This program is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public License
8 as published by the Free Software Foundation; either version 3
9 of the License, or (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19 */
020
121 #include "RandomFieldsUtils.h"
222 #include "General_utils.h"
3 #include "init_RandomFieldsUtils.h"
4
5 static int ORDERDIM;
6 static double *ORDERD;
7 static int *ORDERDINT;
8 static int order_from, order_to;
9
10 typedef bool (*vergleich)(int, int);
11 vergleich SMALLER=NULL, GREATER=NULL;
12
13 bool smaller(int i, int j)
23 #include "zzz_RandomFieldsUtils.h"
24
25
26 typedef bool (*vergleich)(int, int, void *O);
27
28 bool smaller1(int i, int j, void *ORDERD) {
29 return ((double *) ORDERD)[i] < ((double *) ORDERD)[j];
30 }
31
32 bool greater1(int i, int j, void *ORDERD) {
33 return ((double *) ORDERD)[i] > ((double *) ORDERD)[j];
34 }
35
36 bool smallerInt1(int i, int j, void *ORDERDINT) {
37 return ((int *) ORDERDINT)[i] < ((int *)ORDERDINT)[j];
38 }
39
40 bool greaterInt1(int i, int j, void *ORDERDINT) {
41 return ((int *)ORDERDINT)[i] > ((int *)ORDERDINT)[j];
42 }
43
44 typedef bool (*vergleichX)(int, int, int, void *O);
45 vergleichX SMALLERX=NULL, GREATERX=NULL;
46
47 bool smaller(int i, int j, int ORDERDIM, void *O)
1448 {
15 double *x, *y;
49 double *x, *y, *ORDERD = (double*) O;
1650 int d;
1751 x = ORDERD + i * ORDERDIM;
1852 y = ORDERD + j * ORDERDIM;
2155 return false;
2256 }
2357
24 bool greater(int i, int j)
58 bool greater(int i, int j, int ORDERDIM, void *O)
2559 {
26 double *x, *y;
60 double *x, *y, *ORDERD = (double*) O;
2761 int d;
2862 x = ORDERD + i * ORDERDIM;
2963 y = ORDERD + j * ORDERDIM;
3266 return false;
3367 }
3468
35 bool smaller1(int i, int j) {
36 return ORDERD[i] < ORDERD[j];
37 }
38
39 bool greater1(int i, int j) {
40 return ORDERD[i] > ORDERD[j];
41 }
42
43 bool smallerInt(int i, int j)
69 bool smallerInt(int i, int j, int ORDERDIM, void *O)
4470 {
45 int *x, *y;
71 int *x, *y, *ORDERDINT = (int*) O;
4672 int d;
4773 x = ORDERDINT + i * ORDERDIM;
4874 y = ORDERDINT + j * ORDERDIM;
5480 return false;
5581 }
5682
57 bool greaterInt(int i, int j)
83 bool greaterInt(int i, int j, int ORDERDIM, void *O)
5884 {
59 int *x, *y;
85 int *x, *y, *ORDERDINT = (int*) O;
6086 int d;
6187 x = ORDERDINT + i * ORDERDIM;
6288 y = ORDERDINT + j * ORDERDIM;
6692 }
6793
6894
69 bool smallerInt1(int i, int j) {
70 return ORDERDINT[i] < ORDERDINT[j];
71 }
72
73 bool greaterInt1(int i, int j) {
74 return ORDERDINT[i] > ORDERDINT[j];
75 }
76
77
78 void order(int *pos, int start, int end) {
95 void order(int *pos, int start, int end, vergleich SMALLER, vergleich GREATER,
96 void * ORDERD, int order_from, int order_to) {
7997 int randpos, pivot, left, right, pivotpos, swap;
8098
8199 if( start < end ) {
90108 right=end+1;
91109 while (left < right) {
92110 //printf("order > %ld start=%d %d left=%d %d %d pivot=%d\n", pos, start, end, left, right, pos[left], pivot);
93 while (++left < right && SMALLER(pos[left], pivot)) pivotpos++;
94 while (--right > left && GREATER(pos[right], pivot));
111 while (++left < right && SMALLER(pos[left], pivot, ORDERD)) pivotpos++;
112 while (--right > left && GREATER(pos[right], pivot, ORDERD));
95113 if (left < right) {
96114 swap=pos[left]; pos[left]=pos[right]; pos[right]=swap;
97115 pivotpos++;
100118 pos[start] = pos[pivotpos];
101119 pos[pivotpos] = pivot;
102120 if (start <= order_to && pivotpos > order_from)
103 order(pos, start, pivotpos-1);
121 order(pos, start, pivotpos-1, SMALLER, GREATER,
122 ORDERD, order_from, order_to);
104123 if (pivotpos < order_to && end >= order_from)
105 order(pos, pivotpos + 1, end);
124 order(pos, pivotpos + 1, end, SMALLER, GREATER,
125 ORDERD, order_from, order_to);
126 }
127 }
128
129
130 void Xorder(int *pos, int start, int end, vergleichX SMALLER,vergleichX GREATER,
131 int D, void * ORDERD, int order_from, int order_to ) {
132 int randpos, pivot, left, right, pivotpos, swap;
133
134 if( start < end ) {
135 //Get RNGstate();randpos = start + (int) (UNIFORM_RANDOM * (end-start+1)); PutRNGstate(); // use Get/Put RNGstate with great care !!
136 randpos = (int) (0.5 * (start + end));
137 pivot = pos[randpos];
138 pos[randpos] = pos[start];
139 pos[start] = pivot;
140
141 pivotpos=start;
142 left = start;
143 right=end+1;
144 while (left < right) {
145 //printf("order > %ld start=%d %d left=%d %d %d pivot=%d\n", pos, start, end, left, right, pos[left], pivot);
146 while (++left < right && SMALLER(pos[left], pivot, D, ORDERD)) pivotpos++;
147 while (--right > left && GREATER(pos[right], pivot, D, ORDERD));
148 if (left < right) {
149 swap=pos[left]; pos[left]=pos[right]; pos[right]=swap;
150 pivotpos++;
151 }
152 }
153 pos[start] = pos[pivotpos];
154 pos[pivotpos] = pivot;
155 if (start <= order_to && pivotpos > order_from)
156 Xorder(pos, start, pivotpos-1, SMALLER, GREATER,
157 D, ORDERD, order_from, order_to);
158 if (pivotpos < order_to && end >= order_from)
159 Xorder(pos, pivotpos + 1, end, SMALLER, GREATER,
160 D, ORDERD, order_from, order_to);
106161 }
107162 }
108163
135190 assert(NAstart + 1 == start);
136191 }
137192 }
138 order_from = from - 1;
139 order_to = to - 1;
140 ORDERD = d;
141 ORDERDIM = dim;
142193 if (dim == 1) {
143 // print("start\n");
144 SMALLER = smaller1;
145 GREATER = greater1;
194 order(pos, start, end, smaller1, greater1, (void *) d, from - 1, to - 1);
146195 } else {
147 SMALLER = smaller;
148 GREATER = greater;
149 }
150 order(pos, start, end);
196 Xorder(pos, start, end, smaller, greater, dim, (void*) d, from - 1, to - 1);
197 }
151198 }
152199
153200 void Ordering(double *d, int *len, int *dim, int *pos) {
192239 if (NAstart + 1 != start) BUG;
193240 }
194241 }
195 order_from = from - 1;
196 order_to = to - 1;
197 ORDERDINT = d;
198 ORDERDIM = dim;
199242 if (dim == 1) {
200 SMALLER = smallerInt1;
201 GREATER = greaterInt1;
243 order(pos, start, end, smallerInt1, greaterInt1, (void *) d, from-1, to-1);
202244 } else {
203 SMALLER = smallerInt;
204 GREATER = greaterInt;
245 Xorder(pos, start, end, smallerInt, greaterInt, dim, (void*) d, from-1, to-1);
205246 }
206 order(pos, start, end);
207247 }
208248
209249 void orderingInt(int *d, int len, int dim, int *pos) {
213253
214254
215255
216 void quicksort(int start, int end) {
256 void quicksort(int start, int end, double *ORDERD, int order_from, int order_to)
257 {
217258 // printf("start %d %d\n", start, end);
218259
219260 int left, right, pivotpos;
230271 right = end+1;
231272
232273 while (left < right) {
233 //printf("order > start=%d %d left=%d %d %f pivot=%f\n", start, end, left, right, ORDERD[left], pivot);
274 //printf("order > start=%d %d left=%d %d %10g pivot=%10g\n", start, end, left, right, ORDERD[left], pivot);
234275 while (++left < right && ORDERD[left] < pivot) pivotpos++;
235276 while (--right > left && ORDERD[right] > pivot);
236277 if (left < right) {
243284 ORDERD[start] = ORDERD[pivotpos];
244285 ORDERD[pivotpos] = pivot;
245286 if (start <= order_to && pivotpos > order_from)
246 quicksort(start, pivotpos-1);
287 quicksort(start, pivotpos-1, ORDERD, order_from, order_to);
247288 if (pivotpos < order_to && end >= order_from)
248 quicksort(pivotpos + 1, end);
289 quicksort(pivotpos + 1, end, ORDERD, order_from, order_to);
249290 }
250291 }
251292
285326 // print("Rstart %d %d %d\n", start, end, NAstart);
286327 assert(NAstart == start);
287328 }
288 order_from = from - 1;
289 order_to = to - 1;
290 ORDERD = d;
291329 // print("Xstart %d %d\n", start, end);
292 quicksort(start, end);
293 // for (int i=0; i<len; i++) printf("%f\n", d[i]); BUG;
330 quicksort(start, end, d, from - 1, to - 1);
331 // for (int i=0; i<len; i++) printf("%10g\n", d[i]); BUG;
294332 }
295333
296334 void sorting(double *d, int len, usr_bool NAlast) {
297335 sortingFromTo(d, len, 1, len, NAlast);
298336 }
299337
300 void sortInt(int start, int end) {
338 void sortInt(int start, int end, int *ORDERDINT, int order_from, int order_to) {
301339 // printf("start %d %d\n", start, end);
302340
303341 int left, right, pivotpos;
326364 ORDERDINT[start] = ORDERDINT[pivotpos];
327365 ORDERDINT[pivotpos] = pivot;
328366 if (start <= order_to && pivotpos > order_from)
329 sortInt(start, pivotpos-1);
367 sortInt(start, pivotpos-1, ORDERDINT, order_from, order_to);
330368 if (pivotpos < order_to && end >= order_from)
331 sortInt(pivotpos + 1, end);
369 sortInt(pivotpos + 1, end, ORDERDINT, order_from, order_to);
332370 }
333371 }
334372
373411 }
374412 assert(NAstart == start);
375413 }
376 order_from = from - 1;
377 order_to = to - 1;
378 ORDERDINT = d;
379 sortInt(start, end);
414 sortInt(start, end, d, from - 1, to - 1);
380415 }
381416
382417 void sortingInt(int *d, int len, usr_bool NAlast) {
394429 to = MIN(INTEGER(To)[0], len);
395430 if (from > to) return R_NilValue;
396431
397 usr_bool nalast = LOGICAL(NAlast)[0] == NA_LOGICAL ? Nan :
398 LOGICAL(NAlast)[0] ? True : False;
432 usr_bool nalast;
433 if (LOGICAL(NAlast)[0] == NA_LOGICAL) nalast = Nan;
434 else nalast = LOGICAL(NAlast)[0] ? True : False;
399435 SEXP Ans;
400436
401437 if (TYPEOF(Data) == REALSXP) {
453489 SEXP Ans;
454490 PROTECT(Ans=allocVector(INTSXP, to - from + 1));
455491
456 usr_bool nalast = LOGICAL(NAlast)[0] == NA_LOGICAL ? Nan :
457 LOGICAL(NAlast)[0] ? True : False;
492 usr_bool nalast;
493 if ( LOGICAL(NAlast)[0] == NA_LOGICAL) nalast = Nan;
494 else nalast = LOGICAL(NAlast)[0] ? True : False;
458495 int
459496 bytes = len * sizeof(int),
460497 *pos = (int*) MALLOC(bytes);
510547 ordering(data, len, dim, pos, from, to, nalast);
511548 from--;
512549 for (int i=from; i<to; i++) {
513 //printf("%d %d %d %f ", i, from, pos[i], data[pos[i]]);
550 //printf("%d %d %d %10g ", i, from, pos[i], data[pos[i]]);
514551 ans[i - from] = data[pos[i]];
515552 }
516553 } else if (TYPEOF(Data) == INTSXP) {
0 c
1 c Authors:
2 c Reinhard Furrer
3 c
4 c Copyright (C) 2017 -- 2017 Reinhard Furrer
5 c
6 c This program is free software; you can redistribute it and/or
7 c modify it under the terms of the GNU General Public License
8 c as published by the Free Software Foundation; either version 3
9 c of the License, or (at your option) any later version.
10 c
11 c This program is distributed in the hope that it will be useful,
12 c but WITHOUT ANY WARRANTY; without even the implied warranty of
13 c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 c GNU General Public License for more details.
15 c
16 c You should have received a copy of the GNU General Public License
17 c along with this program; if not, write to the Free Software
18 c Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19
20
021 subroutine amuxmat (n,m,p, x, y, a,ja,ia)
122 implicit none
223 integer n, m, p, ja(*), ia(*)
18681889 c x = The solution of R x = b .
18691890 c--------------------------------------------------------------------
18701891 c Reinhard Furrer June 2008, April 2012
1871
1892
1893 k = 0
18721894 if (r(ir(n+1)-1) .eq. 0.0 ) goto 5
18731895 do l=1,p
18741896 x(n,l) = b(n,l) / r(ir(n+1)-1)
44
55 Collection of system specific auxiliary functions
66
7 Copyright (C) 2001 -- 2015 Martin Schlather,
7 Copyright (C) 2001 -- 2017 Martin Schlather,
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
2121 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
2222 */
2323
24 #include <Rmath.h>
25 #include <unistd.h>
24 //#include <Rmath.h>
25 //#include <unistd.h>
2626 #include "RandomFieldsUtils.h"
27 #include "win_linux_aux.h"
27 //#include "win_linux_aux.h"
2828 #include "General_utils.h"
29
30
31 SEXP getChar() {
32 ERR("does not work");
29 #include "intrinsics.h"
30 //#include "Solve.h"
31 #include "Utils.h"
32 #include "own.h"
33
34
35 SEXP getChar() { ERR("does not work");
3336 #ifdef WIN32
3437 ERR("input limitations on windows");
3538 #endif
6871 }
6972 }
7073 //endwin();
71 //printf(">%s<\n", s);
74 //printf(">%.50s<\n", s);
7275 PROTECT(str=allocVector(STRSXP, 1));
7376 SET_STRING_ELT(str, 0, mkChar(s));
7477 UNPROTECT(1);
7780 }
7881
7982
83
84
85
86
87 SEXP DivByRow(SEXP M, SEXP V) {
88 int
89 l = length(V),
90 r = nrows(M),
91 c = ncols(M);
92
93 double *m = REAL(M),
94 *v = REAL(V);
95
96 if (l != c) ERR("vector does not match matrix");
97 for (int j=0; j<c; j++) {
98 double vj = v[j];
99 for (int i=0; i<r; i++) {
100 *(m++) /= vj;
101 }
102 }
103
104 return M;
105 }
106
107
108 void colMaxsIint(int *M, int r, int c, int *ans) {
109 #ifdef DO_PARALLEL
110 #pragma omp parallel for num_threads(CORES)
111 #endif
112 for (int i=0; i<c; i++) {
113 int dummy,
114 *m = M + r * i;
115 #if defined SSE4 or defined AVX2
116 int *start = algnInt(m),
117 *end = m + r;
118 uintptr_t End = (uintptr_t) (end - integers);
119 if ((uintptr_t) start < End) {
120 BlockType *m0 = (BlockType*) start,
121 Dummy = LOAD((BlockType*) m0);
122 for (m0++ ; (uintptr_t) m0 < End; m0++) {
123 Dummy = MAXINTEGER(Dummy, LOAD(m0));
124 }
125 double *d = (double *) &Dummy;
126 dummy = d[0];
127 dummy = MAX(dummy, d[1]);
128 dummy = MAX(dummy, d[2]);
129 dummy = MAX(dummy, d[3]);
130 #if defined AVX2
131 dummy = MAX(dummy, d[4]);
132 dummy = MAX(dummy, d[5]);
133 dummy = MAX(dummy, d[6]);
134 dummy = MAX(dummy, d[7]);
135
136 #endif // AVX
137 for ( ; m<start; m++) dummy = MAX(dummy, *m);
138 m = (int *) m0;
139 for ( ; m<end; m++) dummy = MAX(dummy, *m);
140 } else {
141 dummy = m[0];
142 for (int j=1; j<r; j++) dummy = MAX(dummy, m[j]);
143 }
144 #else // SSE
145 dummy = m[0];
146 for (int j=1; j<r; j++) dummy = MAX(dummy, m[j]);
147 #endif
148 ans[i] = dummy;
149 }
150 }
151
152
153 void colMaxsI(double *M, int r, int c, double *ans) {
154 #ifdef DO_PARALLEL
155 #pragma omp parallel for num_threads(CORES)
156 #endif
157 for (int i=0; i<c; i++) {
158 // printf("i=%d\n", i);
159 double dummy,
160 *m = M + r * i;
161 #if defined SSE2
162 double *start = algn(m),
163 *end = m + r;
164 uintptr_t End = (uintptr_t) (end - doubles);
165 if ((uintptr_t) start < End) {
166 Double * m0 = (Double*) start,
167 Dummy = (Double) LOAD((UBlockType*) m0);
168 for (m0++ ; (uintptr_t) m0 < End; m0++) {
169 Dummy = MAXDOUBLE(Dummy, (Double) LOAD((UBlockType*) m0));
170 }
171 double *d = (double *) &Dummy;
172 dummy = d[0];
173 dummy = MAX(dummy, d[1]);
174 #if defined AVX
175 dummy = MAX(dummy, d[2]);
176 dummy = MAX(dummy, d[3]);
177 #endif
178 for ( ; m<start; m++) dummy = MAX(dummy, *m);
179 m = (double *) m0;
180 for ( ; m<end; m++) dummy = MAX(dummy, *m);
181 } else {
182 dummy = m[0];
183 for (int j=1; j<r; j++) dummy = MAX(dummy, m[j]);
184 }
185 #else
186 dummy = m[0];
187 for (int j=1; j<r; j++) dummy = MAX(dummy, m[j]);
188 #endif
189 ans[i] = dummy;
190 }
191 }
192
193
194 SEXP colMaxs(SEXP M) {
195 int
196 r = nrows(M),
197 c = ncols(M);
198 if (r == 0) return R_NilValue;
199 SEXP Ans;
200 if (TYPEOF(M) == REALSXP) {
201 PROTECT(Ans = allocVector(REALSXP, c));
202 colMaxsI(REAL(M), r, c, REAL(Ans));
203 } else {
204 bool i = TYPEOF(M) == INTSXP;
205 PROTECT(Ans = allocVector(i ? INTSXP : LGLSXP, c));
206 int *m, *a;
207 if (i) {
208 m = INTEGER(M);
209 a = INTEGER(Ans);
210 } else {
211 m = LOGICAL(M);
212 a = LOGICAL(Ans);
213 }
214 colMaxsIint(m, r, c, a);
215 }
216 UNPROTECT(1);
217 return Ans;
218 }
219
220
221 SEXP rowProd(SEXP M) {
222 int
223 r = nrows(M),
224 r4 = r / 4,
225 c = ncols(M);
226 if (r == 0) return R_NilValue;
227 SEXP Ans;
228 if (TYPEOF(M) == REALSXP) {
229 PROTECT(Ans = allocVector(REALSXP, r));
230 double *ans = REAL(Ans),
231 *m = REAL(M);
232 MEMCOPY(ans, m, sizeof(double) * r);
233 m += r;
234 for (int ic=1; ic<c; ic++) {
235 double *a = ans;
236 for (int ir=0; ir<r4; ir++) {
237 *(a++) *= *(m++);
238 *(a++) *= *(m++);
239 *(a++) *= *(m++);
240 *(a++) *= *(m++);
241 }
242 for (int ir=r4 * 4; ir<r; ir++) *(a++) *= *(m++);
243 }
244 } else {
245 // printf("type = %d", TYPEOF(M));
246 RFERROR("transform to double first") ;
247 }
248 UNPROTECT(1);
249 return Ans;
250 }
251
252 SEXP rowMeansX(SEXP M, SEXP Weight) {
253 // todo : SSE2 / AVX
254 int
255 r = nrows(M),
256 c = ncols(M);
257 if (r == 0 || c == 0) return R_NilValue;
258 if (length(Weight) != c && length(Weight) != 0)
259 ERR("Length of 'weight' must equal number of columns of 'x'.");
260 SEXP Ans;
261 PROTECT(Ans = allocVector(REALSXP, r));
262 double *ans = REAL(Ans);
263 for (int j=0; j<r; j++) ans[j] = 0.0;
264 if (length(Weight) == 0) {
265 #define for1 \
266 for (int i=0; i<c; i++, m+=r) { \
267 for (int j=0; j<r; j++) ans[j] += (double) m[j]; \
268 }
269
270 if (TYPEOF(M) == REALSXP) { double *m = REAL(M); for1; }
271 else {
272 int *m;
273 if (TYPEOF(M) == INTSXP) m = INTEGER(M); else m = LOGICAL(M);
274 for1;
275 }
276
277 } else {
278 double *weight = ToReal(Weight);
279 #define for2 \
280 for (int i=0; i<c; i++, m+=r) { \
281 double dummy = weight[i]; /* load1(weight); MULTDOUBLE */ \
282 for (int j=0; j<r; j++) ans[j] += (double) m[j] * dummy; \
283 }
284
285 if (TYPEOF(M) == REALSXP) { double *m = REAL(M); for2; }
286 else {
287 int *m;
288 if (TYPEOF(M) == INTSXP) m = INTEGER(M); else m = LOGICAL(M);
289 for2;
290 }
291
292 if (TYPEOF(Weight) != REALSXP) FREE(weight);
293 }
294 double invc = 1.0 / (double) c;
295 for (int j=0; j<r; j++) ans[j] *= invc;
296 UNPROTECT(1);
297 return Ans;
298 }
299
300 SEXP dbinorm(SEXP X, SEXP Sigma) { // 12'41
301 int nrow,
302 ncol = 2;
303 double *x, *y;
304 if (TYPEOF(X) == VECSXP) {
305 if (length(X) != ncol) BUG;
306 SEXP xx = VECTOR_ELT(X, 0);
307 nrow = length(xx);
308 x = REAL(xx);
309 y = REAL(VECTOR_ELT(X, 1));
310 } else {
311 if (isMatrix(X)) {
312 if (ncols(X) != ncol) BUG;
313 nrow = nrows(X);
314 } else if (isVector(X)) {
315 if (length(X) != ncol) BUG;
316 nrow = 1;
317 } else BUG;
318 x = REAL(X);
319 y = x + nrow;
320 }
321
322
323 SEXP Ans;
324 PROTECT(Ans = allocVector(REALSXP, nrow));
325 double *ans = REAL(Ans);
326 // int nrow4 = nrow - 4;
327 if (length(Sigma) == 0) {
328 double invtwopi = 1.0 / TWOPI;
329 /*
330 minushalfX[4] ={-0.5, -0.5, -0.5, -0.5},
331 invtwopiX [4] = {invtwopi, invtwopi, invtwopi, invtwopi};
332 int i=0;
333
334 #define atonce 4
335 __m256d minushalf4 = LOADuDOUBLE(minushalfX),
336 invtwopi4 = LOADuDOUBLE(invtwopiX);
337
338 for (; i<nrow4; i+=atonce) {
339 __m256d x4 = LOADuDOUBLE(x + i);
340 double *xx4 = (double *) &x4;
341 x4 = MULTDOUBLE(x4, x4);
342 {
343 __m256d y4 = LOADuDOUBLE(y + i);
344 y4 = MULTDOUBLE(y4, y4);
345 x4 = ADDDOUBLE(x4, y4);
346 }
347 x4 = MULTDOUBLE(minushalf4, x4);
348 xx4[0] = EXP(xx4[0]);
349 xx4[1] = EXP(xx4[1]);
350 xx4[2] = EXP(xx4[2]);
351 xx4[3] = EXP(xx4[3]);
352 x4 = MULTDOUBLE(x4, invtwopi4);
353 STOREuDOUBLE(ans + i, x4);
354 }
355 */
356 for (int i=0; i<nrow; i++)
357 ans[i] = EXP(-0.5 * (x[i] * x[i] + y[i] * y[i])) * invtwopi;
358 } else {
359 double *sigma=REAL(Sigma),
360 sigma1 = sigma[0],
361 sigma4 = sigma[3],
362 inv2piSrtS = 1.0 / (TWOPI * SQRT(sigma1 * sigma4)),
363 invS1half = 0.5 / sigma1,
364 invS4half = 0.5 / sigma4;
365 if (sigma[1] == 0.0 && sigma[2] == 0.0) {
366 for (int i=0 ; i<nrow; i++)
367 ans[i] = EXP(- (x[i] * x[i] * invS1half + y[i] * y[i] * invS4half) )
368 * inv2piSrtS;
369 } else BUG;
370 }
371 UNPROTECT(1);
372 return Ans;
373 }
374
375 bool ToFalse[1] = { false };
376 double *ToRealDummy = NULL;
377 int ToRealN = 0;
378
379 double *ToRealI(SEXP X, bool *create) {
380 if (TYPEOF(X) == REALSXP) {
381 *create = false;
382 return REAL(X);
383 }
384 HELPINFO("Better use 'double' as storage mode (for one of the arguments).");
385 int len = length(X);
386 double *y;
387 if (create || ToRealN < len) {
388 y = (double *) MALLOC(sizeof(double) * len);
389 if (y == NULL) ERR1("not enough memory for an %d vector of doubles", len);
390 if (!create) {
391 FREE(ToRealDummy);
392 ToRealDummy = y;
393 ToRealN = len;
394 }
395 } else y = ToRealDummy;
396 int *x;
397 if (TYPEOF(X)==INTSXP) x=INTEGER(X); else x=LOGICAL(X);
398 for (int i=0; i<len; i++) y[i] = (double) x[i];
399 return y;
400 }
401 double *ToReal(SEXP X) {
402 if (TYPEOF(X) == REALSXP) return REAL(X);
403 return ToRealI(X, ToFalse);
404 }
405
406 int *ToIntDummy = NULL;
407 int ToIntN = 0;
408 int *ToIntI(SEXP X, bool *create, bool round) {
409 if (TYPEOF(X) == INTSXP) {
410 *create = false;
411 return INTEGER(X);
412 }
413 if (TYPEOF(X) == LGLSXP) {
414 *create = false;
415 return LOGICAL(X);
416 }
417 HELPINFO("Better use 'integer' as storage mode (for one of the arguments).");
418 int len = length(X);
419 int *y;
420 if (create || ToIntN < len) {
421 y = (int *) MALLOC(sizeof(int) * len);
422 if (y == NULL) ERR1("not enough memory for an %d vector of integers", len);
423 if (!create) {
424 FREE(ToIntDummy);
425 ToIntDummy = y;
426 ToIntN = len;
427 }
428 } else y = ToIntDummy;
429 double *x = (double *) REAL(X);
430 if (round) for (int i=0; i<len; i++) y[i] = (int) ROUND(x[i]);
431 else for (int i=0; i<len; i++) y[i] = (int) x[i];
432 return y;
433 }
434
435 int *ToInt(SEXP X) {
436 if (TYPEOF(X) == INTSXP) return INTEGER(X);
437 if (TYPEOF(X) == LGLSXP) return LOGICAL(X);
438 return ToIntI(X, ToFalse, false);
439 }
440
441 void freeGlobals() {
442 FREE(ToRealDummy);
443 FREE(ToIntDummy);
444 }
445
446
447 SEXP quadratic(SEXP x, SEXP A) {
448 SEXP ans;
449 int len = length(x);
450 if (len != nrows(A) || len != ncols(A)) ERR("'x' and 'A' do not match.");
451 PROTECT(ans = allocVector(REALSXP, 1));
452 xAx(REAL(x), REAL(A), len, REAL(ans));
453 UNPROTECT(1);
454 return ans;
455 }
456
457 SEXP dotXV(SEXP M, SEXP V) {
458 int
459 r = nrows(M),
460 c = ncols(M),
461 l = length(V)
462 ;
463 if (l != r) ERR("X and v do not match");
464 if (r == 0) return R_NilValue;
465 SEXP Ans;
466 PROTECT(Ans = allocMatrix(REALSXP, r, c));
467
468 // bringt nix
469 //#ifdef DO_PARALLEL
470 //#pragma omp parallel for num_threads(CORES)
471 //#endif
472 for (int i=0; i<c; i++) {
473 // printf("i=%d\n", i);
474 #if defined SSE2_DONOTUSE_AS_SLOWER
475 double
476 *ans = REAL(Ans) + r * i,
477 *v = REAL(V),
478 *m = REAL(M) + r * i,
479 *end = m + r - doubles;
480 for ( ; m < end; m += doubles, ans += doubles, v += doubles)
481 STOREuDOUBLE(ans, MULTDOUBLE(LOADuDOUBLE(m), LOADuDOUBLE(v)));
482 end += doubles;
483 for (; m < end; m++) *ans = *m * *v;
484 #else
485 double
486 *ans = REAL(Ans) + r * i,
487 *v = REAL(V),
488 *m = REAL(M) + r * i;
489 for (int j=0; j<r; j++) {
490 ans[j] = m[j] * v[j];
491 }
492
493 #endif
494 }
495
496 UNPROTECT(1);
497 return Ans;
498 }
499
500
44
55 Collection of system specific auxiliary functions
66
7 Copyright (C) 2001 -- 2015 Martin Schlather,
7 Copyright (C) 2001 -- 2017 Martin Schlather,
88
99 This program is free software; you can redistribute it and/or
1010 modify it under the terms of the GNU General Public License
6363 }
6464
6565 void pid(int *i) {
66 #ifndef WIN32
67 *i = getpid();
66 #ifdef WIN32
67 *i = _getpid();
6868 #else
69 *i = 0;
69 *i = getpid();
7070 #endif
7171 }
7272
55 Martin Schlather, schlather@math.uni-mannheim.de
66
77
8 Copyright (C) 2015 Martin Schlather
8 Copyright (C) 2015 -- 2017 Martin Schlather
99
1010 This program is free software; you can redistribute it and/or
1111 modify it under the terms of the GNU General Public License
0 /*
1 Authors
2 Martin Schlather, schlather@math.uni-mannheim.de
3
4 Copyright (C) 2015 -- 2017 Martin Schlather
5
6 This program is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public License
8 as published by the Free Software Foundation; either version 3
9 of the License, or (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19 */
20
21 //#include "Basic_utils.h" // must be before anything else
22
23 #include "RandomFieldsUtils.h"
24 #include "zzz_RandomFieldsUtils.h"
25 #include "Utils.h"
26
27
28 static R_NativePrimitiveArgType Relax_t[] = { LGLSXP },
29 int_arg[] = { INTSXP },
30 host_arg[] = { STRSXP, INTSXP};
31 // static R_NativeArgStyle argin[] = {R_ARG_IN},
32 // argout[] = {R_ARG_OUT},
33 // hostarg[] = {R_ARG_OUT, R_ARG_OUT};
34
35 #define CDEF(name, n, type) {#name, (DL_FUNC) & name, n, type}
36 static const R_CMethodDef cMethods[] = {
37 CDEF(RelaxUnknownRFoption, 1, Relax_t),
38 CDEF(sleepMilli, 1, int_arg),
39 CDEF(sleepMicro, 1, int_arg),
40 CDEF(pid, 1, int_arg),
41 CDEF(hostname, 2, host_arg),
42 // {"attachRFoptionsUtils", (DL_FUNC) &attachRFoptionsUtils, 0, NULL, NULL},
43 // {"detachRFoptionsUtils", (DL_FUNC) &detachRFoptionsUtils, 0, NULL, NULL},
44 {NULL, NULL, 0, NULL}
45 };
46
47
48
49 #define CALLDEF_DO(name, n) {#name, (DL_FUNC) &name, n}
50 static R_CallMethodDef callMethods[] = {
51 // in die respectiven C-Dateien muss RandomFieldsUtils.h eingebunden sein
52 CALLDEF_DO(Chol, 1),
53 CALLDEF_DO(SolvePosDef, 3),
54 CALLDEF_DO(struve, 4),
55 CALLDEF_DO(I0ML0, 1),
56 CALLDEF_DO(gaussr, 2),
57 CALLDEF_DO(WMr, 4),
58 CALLDEF_DO(logWMr, 4),
59 CALLDEF_DO(attachRandomFieldsUtils, 1),
60 CALLDEF_DO(detachRandomFieldsUtils, 0),
61 CALLDEF_DO(sortX, 4),
62 CALLDEF_DO(orderX, 4),
63 CALLDEF_DO(getChar, 0),
64 CALLDEF_DO(DivByRow, 2),
65 CALLDEF_DO(colMaxs, 1),
66 CALLDEF_DO(quadratic, 2),
67 CALLDEF_DO(dotXV, 2),
68 CALLDEF_DO(rowMeansX, 2),
69 CALLDEF_DO(rowProd, 1),
70 CALLDEF_DO(dbinorm, 2),
71 CALLDEF_DO(chol2mv, 2),
72 CALLDEF_DO(tcholRHS, 2),
73 // CALLDEF_DO(),
74 {NULL, NULL, 0}
75 };
76
77
78
79
80 #define EXTDEF_DO(name, n) {#name, (DL_FUNC) &name, n}
81 static const R_ExternalMethodDef extMethods[] = {
82 // in die respectiven C-Dateien muss RandomFieldsUtils.h eingebunden sein
83 EXTDEF_DO(RFoptions, -1),
84 {NULL, NULL, 0}
85 };
86
87
88
89
90 #define CALLABLE(FCTN) R_RegisterCCallable("RandomFieldsUtils", #FCTN, (DL_FUNC) FCTN)
91 void R_init_RandomFieldsUtils(DllInfo *dll) {
92 CALLABLE(solve_DELETE);
93 CALLABLE(solve_NULL);
94 CALLABLE(solvePosDef);
95 CALLABLE(invertMatrix);
96
97 CALLABLE(sqrtPosDefFree);
98 CALLABLE(sqrtRHS);
99
100 CALLABLE(detPosDef);
101 CALLABLE(XCinvXdet);
102 CALLABLE(XCinvYdet);
103 CALLABLE(is_positive_definite);
104 CALLABLE(chol2inv);
105 CALLABLE(chol);
106
107 CALLABLE(StruveH);
108 CALLABLE(StruveL);
109 CALLABLE(I0mL0);
110
111 CALLABLE(WM);
112 CALLABLE(DWM);
113 CALLABLE(DDWM);
114 CALLABLE(D3WM);
115 CALLABLE(D4WM);
116 CALLABLE(logWM);
117
118 CALLABLE(Gauss);
119 CALLABLE(DGauss);
120 CALLABLE(DDGauss);
121 CALLABLE(D3Gauss);
122 CALLABLE(D4Gauss);
123 CALLABLE(logGauss);
124
125 CALLABLE(getErrorString);
126 CALLABLE(setErrorLoc);
127 CALLABLE(getUtilsParam);
128 CALLABLE(attachRFoptions);
129 CALLABLE(detachRFoptions);
130 CALLABLE(relaxUnknownRFoption);
131
132 CALLABLE(ordering);
133 CALLABLE(orderingInt);
134 CALLABLE(sorting);
135 CALLABLE(sortingInt);
136 CALLABLE(scalarX);
137
138 CALLABLE(ToIntI);
139 // CALLABLE(ToRealI);
140
141 CALLABLE(pid);
142 CALLABLE(sleepMicro);
143
144
145 R_registerRoutines(dll, cMethods, callMethods, NULL, // .Fortran
146 extMethods);
147 R_useDynamicSymbols(dll, FALSE); //
148 }
149
150
151
152 void R_unload_RandomFieldsUtils(DllInfo *info) {
153 // just to avoid warning from compiler on my computer
154 #ifdef SCHLATHERS_MACHINE
155 if (0) Rprintf("%ld\n", (unsigned long) info);
156 #endif
157 /* Release resources. */
158 }
159
160
0
1
2
3 /*
4 Authors
5 Martin Schlather, schlather@math.uni-mannheim.de
6
7
8 Copyright (C) 2015 -- 2017 Martin Schlather
9
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 3
13 of the License, or (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 */
24
25 #ifndef rfutils_init_H
26 #define rfutils_init_H 1
27
28 #include "Options_utils.h"
29 #include "errors_messages.h"
30 #include "scalar.h"
31 #include "Utils.h"
32
33
34 #ifdef HAVE_VISIBILITY_ATTRIBUTE
35 # define attribute_hidden __attribute__ ((visibility ("hidden")))
36 #else
37 # define attribute_hidden
38 #endif
39
40 #ifdef __cplusplus
41 extern "C" {
42 #endif
43
44 #define MY_PACKAGE "RandomFieldsUtils"
45 #define MY_ACRONYM XX
46 #include "zzz_calls.h"
47
48 DECLARE1(void, solve_DELETE, solve_storage**, S)
49 DECLARE1(void, solve_NULL, solve_storage*, x)
50 DECLARE7(int, solvePosDef, double*, M, int, size, bool, posdef,
51 double *, rhs, int, rhs_cols, double *, logdet, solve_storage *, PT)
52 DECLARE8(int, solvePosDefResult, double*, M, int, size, bool, posdef,
53 double *, rhs, int, rhs_cols, double *, result, double*, logdet,
54 solve_storage*, PT)
55 DECLARE4(int, sqrtPosDefFree, double *, M, int, size, solve_storage *, pt,
56 solve_param *, sp)
57 DECLARE3(int, sqrtRHS, solve_storage *, pt, double*, RHS, double *, res)
58 DECLARE2(int, invertMatrix, double *, M, int, size)
59 DECLARE2(double, StruveH, double, x, double, nu)
60 DECLARE3(double, StruveL, double, x, double, nu, bool, expScale1d)
61 DECLARE1(double, I0mL0, double, x)
62 DECLARE3(double, WM, double, x, double, nu, double, factor)
63 DECLARE3(double, DWM, double, x, double, nu, double, factor)
64 DECLARE3(double, DDWM, double, x, double, nu, double, factor)
65 DECLARE3(double, D3WM, double, x, double, nu, double, factor)
66 DECLARE3(double, D4WM, double, x, double, nu, double, factor)
67 DECLARE4(double, logWM, double, x, double, nu1, double, nu2, double, factor)
68 DECLARE1(double, Gauss, double, x)
69 DECLARE1(double, DGauss, double, x)
70 DECLARE1(double, DDGauss, double, x)
71 DECLARE1(double, D3Gauss, double, x)
72 DECLARE1(double, D4Gauss, double, x)
73 DECLARE1(double, logGauss, double, x)
74
75 DECLARE1(void, getErrorString, errorstring_type, errorstring)
76 DECLARE1(void, setErrorLoc, errorloc_type, errorloc)
77 DECLARE1(void, getUtilsParam, utilsparam **, up)
78 DECLARE10(void, attachRFoptions, const char **, prefixlist, int, N,
79 const char ***, all, int *, allN, setparameterfct, set,
80 finalsetparameterfct, final, getparameterfct, get,
81 deleteparameterfct, del,
82 int, PLoffset,
83 bool, basicopt)
84 DECLARE2(void, detachRFoptions, const char **, prefixlist, int, N)
85 DECLARE1(void, relaxUnknownRFoption, bool, relax)
86
87 DECLARE3(void, sorting, double*, data, int, len, usr_bool, NAlast)
88 DECLARE3(void, sortingInt, int*, data, int, len, usr_bool, NAlast)
89 DECLARE4(void, ordering, double*, data, int, len, int, dim, int *, pos)
90 DECLARE4(void, orderingInt, int*, data, int, len, int, dim, int *, pos)
91 DECLARE4(double, scalarX, double *, x, double *, y, int, len, int, n)
92 DECLARE2(double, detPosDef, double *, M, int, size)
93 DECLARE8(int, XCinvXdet,double, *M, int, size, double *,X, int, X_cols,
94 double *, XCinvX, double *, det, bool, log, solve_storage, *PT)
95 DECLARE10(int, XCinvYdet,double, *M, int, size, bool, posdef,
96 double *, X, double *, Y, int, cols,
97 double *, XCinvY, double *, det, bool, log, solve_storage, *PT)
98 // DECLARE5(double, XCinvXlogdet, double *, M, int, size, double *, X,
99 // int, X_cols, solve_storage *, PT)
100 DECLARE2(bool, is_positive_definite, double *, C, int, dim)
101 DECLARE2(void, chol2inv, double *, MPT, int, size)
102 DECLARE2(int, chol, double *, MPT, int, size)
103 // DECLARE2(double *, ToRealI, SEXP, X, bool *, create)
104 DECLARE3(int *, ToIntI, SEXP, X, bool *, create, bool, round)
105 DECLARE1(void, pid, int *, i)
106 DECLARE1(void, sleepMicro, int *, i)
107
108 /*
109
110 See in R package RandomFields, /src/userinterfaces.cc
111 CALL#(...)
112 at the beginning for how to make the functions available
113 in a calling package
114
115 */
116 #ifdef __cplusplus
117 }
118 #endif
119
120
121 #endif
122
123
0
1
2
3 /*
4 Authors
5 Martin Schlather, schlather@math.uni-mannheim.de
6
7
8 Copyright (C) 2015 -- 2017 Martin Schlather
9
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 3
13 of the License, or (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 */
24
25 #ifndef rfutils_calls_H
26 #define rfutils_calls_H 1
27 #include <R_ext/Rdynload.h>
28
29
30 #define CALL0(V, N) \
31 attribute_hidden V RU_##N() { \
32 static V(*fun)(AV) = NULL; \
33 if (fun == NULL) fun = (V (*) ()) R_GetCCallable(MY_PACKAGE, #N); \
34 return fun(); }
35 #define DECLARE0(V, N) \
36 typedef V (*N##_type)(); \
37 /* extern N##_type Ext_##N; */ \
38 attribute_hidden V RU_##N(); \
39 V N();
40
41 #define CALL1(V, N, AV, AN) \
42 /* N##_type Ext_##N = NULL; */ \
43 attribute_hidden V RU_##N(AV AN) { \
44 static N##_type fun = NULL; \
45 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
46 return fun(AN); }
47 #define DECLARE1(V, N, AV, AN) \
48 typedef V (*N##_type)(AV AN); \
49 /* extern N##_type Ext_##N; */ \
50 attribute_hidden V RU_##N(AV AN); \
51 V N(AV AN);
52
53 #define CALL2(V, N, AV, AN, BV, BN) \
54 /* N##_type Ext_##N = NULL; */ \
55 attribute_hidden V RU_##N(AV AN, BV BN) { \
56 static N##_type fun = NULL; \
57 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
58 return fun(AN, BN); }
59 #define DECLARE2(V, N, AV, AN, BV, BN) \
60 typedef V (*N##_type)(AV AN, BV BN); \
61 /* extern N##_type Ext_##N; */ \
62 attribute_hidden V RU_##N(AV AN, BV BN); \
63 V N(AV AN, BV BN);
64
65 #define CALL3(V, N, AV, AN, BV, BN, CV, CN) \
66 /* N##_type Ext_##N = NULL; */ \
67 attribute_hidden V RU_##N(AV AN, BV BN, CV CN) { \
68 static N##_type fun = NULL; \
69 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
70 return fun(AN, BN, CN); }
71 #define DECLARE3(V, N, AV, AN, BV, BN, CV, CN) \
72 typedef V (*N##_type)(AV AN, BV BN, CV CN); \
73 /* extern N##_type Ext_##N; */ \
74 attribute_hidden V RU_##N(AV AN, BV BN, CV CN); \
75 V N(AV AN, BV BN, CV CN);
76
77 #define CALL4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
78 /* N##_type Ext_##N = NULL; */ \
79 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN) { \
80 static N##_type fun = NULL; \
81 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
82 return fun(AN, BN, CN, DN); }
83 #define DECLARE4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \
84 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN); \
85 /* extern N##_type Ext_##N; */ \
86 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN); \
87 V N(AV AN, BV BN, CV CN, DV DN);
88
89 #define CALL5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
90 /* N##_type Ext_##N = NULL; */ \
91 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN) { \
92 static N##_type fun = NULL; \
93 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
94 return fun(AN, BN, CN, DN, EN); }
95 #define DECLARE5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \
96 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN); \
97 /* extern N##_type Ext_##N; */ \
98 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN); \
99 V N(AV AN, BV BN, CV CN, DV DN, EV EN);
100
101 #define CALL6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
102 /* N##_type Ext_##N = NULL; */ \
103 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN) { \
104 static N##_type fun = NULL; \
105 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
106 return fun(AN, BN, CN, DN, EN, FN); }
107 #define DECLARE6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \
108 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
109 /* extern N##_type Ext_##N; */ \
110 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \
111 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN);
112
113 #define CALL7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
114 /* N##_type Ext_##N = NULL; */ \
115 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN) { \
116 static N##_type fun = NULL; \
117 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
118 return fun(AN, BN, CN, DN, EN, FN, GN); }
119 #define DECLARE7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \
120 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
121 /* extern N##_type Ext_##N; */ \
122 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \
123 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN);
124
125 #define CALL8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
126 /* N##_type Ext_##N = NULL; */ \
127 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN) { \
128 static N##_type fun = NULL; \
129 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
130 return fun(AN, BN, CN, DN, EN, FN, GN, HN); }
131 #define DECLARE8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \
132 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
133 /* extern N##_type Ext_##N; */ \
134 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \
135 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN);
136
137 #define CALL9(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN) \
138 /* N##_type Ext_##N = NULL; */ \
139 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN) { \
140 static N##_type fun = NULL; \
141 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
142 return fun(AN, BN, CN, DN, EN, FN, GN, HN, IN); }
143 #define DECLARE9(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN) \
144 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN); \
145 /* extern N##_type Ext_##N; */ \
146 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN); \
147 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN);
148
149
150 #define CALL10(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN, JV, JN) \
151 /* N##_type Ext_##N = NULL; */ \
152 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN) { \
153 static N##_type fun = NULL; \
154 if (fun == NULL) fun = (N##_type) R_GetCCallable(MY_PACKAGE, #N); \
155 return fun(AN, BN, CN, DN, EN, FN, GN, HN, IN, JN); }
156 #define DECLARE10(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN, IV, IN, JV, JN) \
157 typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN); \
158 /* extern N##_type Ext_##N; */ \
159 attribute_hidden V RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN); \
160 V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN, IV IN, JV JN);
161
162
163 #endif