New upstream version 0.5.3
Andreas Tille
4 years ago
0 | 0 | Package: RandomFieldsUtils |
1 | Version: 0.3.25 | |
1 | Version: 0.5.3 | |
2 | 2 | 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] | |
4 | 4 | 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 | |
7 | 7 | 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. |
8 | 8 | 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 | |
11 | 12 | NeedsCompilation: yes |
12 | 13 | Repository: CRAN |
13 | Date/Publication: 2017-04-14 15:07:28 UTC | |
14 | Date/Publication: 2019-03-04 12:00:06 UTC |
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 | |
3 | 5 | 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 | |
27 | 45 | 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 |
0 | 0 | |
1 | ||
2 | #exportPattern("^[^\\.]") | |
1 | ###exportPattern("^[^\\.]") | |
3 | 2 | |
4 | 3 | export(cholx, cholPosDef, Print, solvex, solvePosDef, |
5 | 4 | sleep.milli, sleep.micro, hostname, pid, FileExists, LockRemove, |
6 | 5 | sortx, orderx, |
7 | 6 | 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_") | |
9 | 12 | |
10 | 13 | useDynLib(RandomFieldsUtils, .registration = TRUE, .fixes = "C_") |
11 | 14 | #useDynLib(spam) |
12 | 15 | |
13 | importFrom("utils", "str") | |
16 | importFrom("utils", "str", "packageDescription", "contrib.url") | |
17 | importFrom("methods", "hasArg", "is") | |
18 | importFrom("grDevices", "dev.off") | |
14 | 19 | |
15 | 20 | S3method(print, RFopt) |
16 | 21 | S3method(summary, RFopt) |
0 | 0 | |
1 | 1 | |
2 | summary.RFopt <- function(object, ...) { | |
2 | summary.RFopt <- function(object, ...) { | |
3 | 3 | object <- lapply(object, function(z) z[order(names(z))]) |
4 | 4 | object <- object[c(1, 1 + order(names(object[-1])))] |
5 | 5 | class(object) <- "summary.RFopt" |
36 | 36 | RFoptions <- function(..., no.readonly=TRUE) { |
37 | 37 | ## on.exit(.C("RelaxUnknownRFoption", FALSE)) |
38 | 38 | ## .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 | }) | |
45 | 47 | 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() | |
49 | 51 | } |
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 | |
56 | 53 | } |
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) |
74 | 74 | LockRemove <- function(file) { |
75 | 75 | ## removes auxiliary files created by FileExists |
76 | 76 | lock.ext <- ".lock"; |
77 | file.remove(paste(file, lock.ext, sep="")) | |
77 | file.remove(paste0(file, lock.ext)) | |
78 | 78 | } |
79 | 79 | |
80 | 80 | |
122 | 122 | |
123 | 123 | |
124 | 124 | |
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) | |
129 | 126 | |
130 | 127 | cholPosDef <- function() stop("please use 'cholx' instead of 'cholPosDef'.") |
131 | 128 | |
132 | 129 | solvePosDef <- function(a, b=NULL, logdeterminant=FALSE) { |
133 | 130 | stop("please use 'solvex' instead of 'solvePosDef'.") |
134 | 131 | } |
132 | ||
135 | 133 | solvex <- function(a, b=NULL, logdeterminant=FALSE) { |
136 | 134 | if (logdeterminant) { |
137 | 135 | logdet <- double(1) |
180 | 178 | |
181 | 179 | |
182 | 180 | # 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) |
0 | 0 | |
1 | 1 | .onLoad <- function(lib, pkg) { |
2 | .Call("attachRFoptionsUtils") | |
2 | .Call("attachRandomFieldsUtils", interactive()) | |
3 | 3 | } |
4 | 4 | |
5 | 5 | .onAttach <- function (lib, pkg) { |
6 | # packageStartupMessage("This is RandomFieldsUtils Version: 0.3.25"); | |
6 | # packageStartupMessage("This is RandomFieldsUtils Version: 0.5.3"); | |
7 | 7 | } |
8 | 8 | |
9 | 9 | .onDetach <- function(lib) { |
10 | # .Call("detachRFoptionsUtils") | |
10 | # .Call("detachRanodmFieldsUtils") | |
11 | 11 | } |
12 | 12 | |
13 | 13 | .onUnload <- function(lib, pkg){ |
14 | .Call("detachRFoptionsUtils") | |
14 | .Call("detachRandomFieldsUtils") | |
15 | 15 | } |
7 | 7 | footer="", |
8 | 8 | title = "{RandomFieldsUtils}: Utilites for the Simulation and Analysis of Random Fields", |
9 | 9 | 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"), | |
12 | 13 | year = year, |
13 | 14 | note = note, |
14 | 15 | 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 | ||
3 | 0 | /* |
4 | 1 | Authors |
5 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
6 | 3 | |
7 | 4 | |
8 | Copyright (C) 2015 Martin Schlather | |
5 | Copyright (C) 2015 -- 2017 Martin Schlather | |
9 | 6 | |
10 | 7 | This program is free software; you can redistribute it and/or |
11 | 8 | modify it under the terms of the GNU General Public License |
31 | 28 | #endif |
32 | 29 | #include <R.h> |
33 | 30 | #include <Rmath.h> |
31 | #include "AutoRandomFieldsUtils.h" | |
34 | 32 | |
33 | ||
34 | #ifndef DO_PARALLEL_ALREADY_CONSIDERED | |
35 | 35 | |
36 | 36 | #ifdef _OPENMP |
37 | 37 | #define DO_PARALLEL 1 |
40 | 40 | #undef DO_PARALLEL |
41 | 41 | #endif |
42 | 42 | #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 | ||
43 | 58 | |
44 | 59 | #define MULTIMINSIZE(S) ((S) > 20) |
45 | 60 | // #define MULTIMINSIZE(S) false |
52 | 67 | |
53 | 68 | |
54 | 69 | #define DOPRINT true |
55 | // | |
56 | #define SCHLATHERS_MACHINE 1 | |
70 | //#define SCHLATHERS_MACHINE 1 | |
57 | 71 | |
58 | // // 1 | |
72 | ||
59 | 73 | // #define HIDE_UNUSED_VARIABLE 1 |
60 | 74 | |
61 | 75 | |
62 | 76 | #ifdef __cplusplus |
63 | 77 | extern "C" { |
64 | 78 | #endif |
65 | // Fortran Code by Reinhard Furrer | |
66 | 79 | void spamcsrdns_(int*, double *, int *, int*, double*); |
67 | 80 | void spamdnscsr_(int*, int*, double *, int*, double*, int*, int*, double*); |
68 | 81 | void cholstepwise_(int*, int*, double*, int*, int*, int*, int*, int*, |
98 | 111 | #define RF_INF R_PosInf |
99 | 112 | #define T_PI M_2_PI |
100 | 113 | |
101 | #define MAXUNITS 4 | |
102 | #define MAXCHAR 18 // max number of characters for (covariance) names | |
103 | 114 | #define OBSOLETENAME "obsolete" |
104 | #define RFOPTIONS "RFoptions" | |
105 | 115 | |
106 | 116 | #define MAXINT 2147483647 |
117 | #define MININT -2147483647 | |
118 | #define MAXUNSIGNED (MAXINT * 2) + 1 | |
107 | 119 | #define INFDIM MAXINT |
108 | 120 | #define INFTY INFDIM |
109 | ||
110 | 121 | |
111 | 122 | #define LENGTH length // safety, in order not to use LENGTH defined by R |
112 | 123 | #define complex Rcomplex |
138 | 149 | #define MAX(A,B) ((A) > (B) ? (A) : (B)) |
139 | 150 | |
140 | 151 | |
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 | |
144 | 155 | #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 | |
147 | 158 | #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 | |
150 | 161 | #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 | |
152 | 164 | #define SQRT(X) std::sqrt((double) X) |
153 | 165 | #define STRCMP(A, B) std::strcmp(A, B) |
154 | 166 | #define STRCPY(A, B) std::strcpy(A, B) |
155 | #define STRLEN(X) std::strlen(X) | |
167 | #define STRLEN std::strlen | |
156 | 168 | #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 | |
158 | 171 | #define MEMCOPYX std::memcpy |
172 | #define MEMSET std::memset | |
173 | #define AALLOC std::aligned_alloc | |
159 | 174 | #define CALLOCX std::calloc |
160 | 175 | #define MALLOCX std::malloc |
161 | 176 | #define FREEX std::free |
162 | 177 | #define SPRINTF std::sprintf // |
163 | #define ROUND(X) std::round(X) | |
178 | #define ROUND(X) ownround((double) X) | |
164 | 179 | #define TRUNC(X) ftrunc((double) X) // keine Klammern um X! |
165 | 180 | #define QSORT std::qsort |
166 | 181 | |
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 | |
167 | 189 | #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 |
4 | 4 | Martin Schlather, schlather@math.uni-mannheim.de |
5 | 5 | |
6 | 6 | |
7 | Copyright (C) 2015 Martin Schlather | |
7 | Copyright (C) 2015 -- 2017 Martin Schlather | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
34 | 34 | #include "errors_messages.h" |
35 | 35 | #include "kleinkram.h" |
36 | 36 | #include "Solve.h" |
37 | #include "scalar.h" | |
37 | 38 | |
38 | 39 | |
39 | ||
40 | #define DOPRINTF if (DOPRINT) Rprintf | |
41 | #define PRINTF Rprintf | |
42 | #define print PRINTF /* // */ | |
43 | 40 | |
44 | 41 | #ifdef HIDE_UNUSED_VARIABLE |
45 | 42 | #define VARIABLE_IS_NOT_USED __attribute__ ((unused)) |
59 | 56 | #define INTERNAL SERR("Sorry. This functionality does not exist currently. There is work in progress at the moment by the maintainer.") |
60 | 57 | #define assert(X) {} |
61 | 58 | #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 .", \ | |
63 | 60 | __FUNCTION__, __FILE__, __LINE__); \ |
64 | RFERROR(BUG_MSG); \ | |
65 | } | |
61 | } | |
66 | 62 | #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__);} | |
68 | 64 | #define MEMCOPY(A,B,C) MEMCOPYX(A,B,C) |
65 | #define AMALLOC(ELEMENTS, SIZE) AALLOC(SIZE, (SIZE) * (ELEMENTS)) | |
69 | 66 | #define MALLOC MALLOCX |
70 | 67 | #define CALLOC CALLOCX |
68 | #define XCALLOC CALLOCX | |
69 | // | |
71 | 70 | #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;} | |
72 | 72 | #define UNCONDFREE(X) {FREEX(X); (X)=NULL;} |
73 | 73 | #endif // not SCHLATHERS_MACHINE |
74 | 74 | |
79 | 79 | #define MAXALLOC 1e9 |
80 | 80 | |
81 | 81 | // __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__); \ | |
92 | 90 | } |
93 | 91 | #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__);} | |
95 | 93 | #define DO_TESTS true |
96 | 94 | |
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); }) | |
98 | 96 | //#define MEMCOPY(A,B,C) memory_copy(A, B, C) |
99 | 97 | #define MALLOC(X) __extension__ ({assert((X)>0 && (X)<=MAXALLOC); MALLOCX(X);}) |
100 | 98 | #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;} | |
103 | 102 | #endif // SCHLATHERS_MACHINE |
104 | 103 | |
105 | 104 | |
107 | 106 | |
108 | 107 | #ifdef RANDOMFIELDS_DEBUGGING |
109 | 108 | #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);}) | |
111 | 110 | // |
112 | 111 | #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);}) | |
114 | 115 | //#define MALLOC malloc |
115 | 116 | //#define CALLOC calloc |
116 | 117 | |
118 | ||
119 | // note that DEBUGINDOERR is redefined in MachineDebugging.h | |
117 | 120 | #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__); \ | |
120 | 123 | } |
121 | #define DEBUGINFO DOPRINTF("(currently at %s, line %d)\n", __FILE__, __LINE__) | |
124 | #define DEBUGINFO DOPRINTF("(currently at %.50s, line %d)\n", __FILE__, __LINE__) | |
122 | 125 | |
123 | 126 | #else |
124 | 127 | #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);} | |
126 | 129 | #endif |
127 | 130 | |
128 | 131 | |
132 | extern int PLoffset; | |
129 | 133 | #define PL_IMPORTANT 1 |
130 | 134 | #define PL_BRANCHING 2 |
131 | 135 | #define PL_DETAILSUSER 3 |
142 | 146 | #define PL_SUBDETAILS 10 |
143 | 147 | |
144 | 148 | #define MATERN_NU_THRES 100 |
149 | #define BESSEL_NU_THRES 100 | |
150 | #define LOW_MATERN 1e-20 | |
151 | #define LOW_BESSEL 1e-20 | |
145 | 152 | |
146 | 153 | |
147 | 154 | #endif |
148 | ||
149 |
4 | 4 | Martin Schlather, schlather@math.uni-mannheim.de |
5 | 5 | |
6 | 6 | |
7 | Copyright (C) 2015 Martin Schlather | |
7 | Copyright (C) 2015 -- 2017 Martin Schlather | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
34 | 34 | |
35 | 35 | #define R_PRINTLEVEL 1 |
36 | 36 | #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; | |
38 | 44 | |
39 | 45 | |
40 | 46 | #define LEN_OPTIONNAME 201 |
41 | 47 | |
42 | #define basicN 7 | |
48 | #define basicN 9 | |
43 | 49 | // IMPORTANT: all names of basic must be at least 3 letters long !!! |
44 | 50 | extern const char *basic[basicN]; |
45 | 51 | typedef struct basic_param { |
46 | bool | |
47 | skipchecks, | |
48 | asList; | |
49 | 52 | int |
50 | 53 | Rprintlevel, |
51 | 54 | Cprintlevel, |
52 | 55 | seed, cores; |
56 | bool skipchecks, asList, kahanCorrection, helpinfo; | |
53 | 57 | } basic_param; |
54 | 58 | #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 \ | |
57 | 61 | } |
58 | 62 | |
59 | 63 | |
60 | #define nr_InversionMethods ((int) Diagonal + 1) | |
61 | #define nr_user_InversionMethods ((int) NoInversionMethod + 1) | |
62 | 64 | extern const char * InversionNames[nr_InversionMethods]; |
63 | 65 | |
64 | #define PIVOT_NONE 0 | |
65 | #define PIVOT_MMD 1 | |
66 | #define PIVOT_RCM 2 | |
67 | 66 | #define SOLVE_SVD_TOL 3 |
68 | #define solveN 12 | |
67 | #define solveN 20 | |
69 | 68 | 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; | |
72 | 73 | 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 | |
75 | 78 | // bool tmp_delete; |
76 | 79 | } solve_param; |
77 | 80 | #ifdef SCHLATHERS_MACHINE |
79 | 82 | #else |
80 | 83 | #define svd_tol_start 0 |
81 | 84 | #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} | |
86 | 93 | extern const char * solve[solveN]; |
87 | 94 | |
88 | 95 | |
93 | 100 | |
94 | 101 | |
95 | 102 | |
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); | |
100 | 108 | #define ADDCHAR(ELT) x[0] = ELT; ADD(ScalarString(mkChar(x))); |
101 | 109 | |
102 | 110 |
2 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
3 | 3 | |
4 | 4 | |
5 | Copyright (C) 2015 Martin Schlather | |
5 | Copyright (C) 2015 -- 2017 Martin Schlather | |
6 | 6 | |
7 | 7 | This program is free software; you can redistribute it and/or |
8 | 8 | modify it under the terms of the GNU General Public License |
19 | 19 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
20 | 20 | */ |
21 | 21 | |
22 | ||
22 | #include "errors_messages.h" | |
23 | 23 | |
24 | 24 | #ifndef rfutils_solve_H |
25 | 25 | #define rfutils_solve_H 1 |
33 | 33 | direct_formula, |
34 | 34 | Diagonal // always last one! |
35 | 35 | } InversionMethod; |
36 | #define nr_InversionMethods ((int) Diagonal + 1) | |
37 | #define nr_user_InversionMethods ((int) NoFurtherInversionMethod + 1) | |
36 | 38 | |
37 | 39 | |
38 | 40 | #define SOLVE_METHODS 3 |
39 | 41 | typedef struct solve_storage { |
42 | errorstring_type err_msg; | |
43 | InversionMethod method, newMethods[SOLVE_METHODS]; | |
44 | usr_bool sparse; | |
40 | 45 | 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, | |
42 | 47 | xlnz_n, snode_n, xsuper_n, xlindx_n, invp_n, |
43 | 48 | 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, | |
48 | 53 | *iwork, *ipiv, |
49 | *pivot, *xlnz, *snode, *xsuper, *xlindx, | |
54 | *pivotsparse, *xlnz, *snode, *xsuper, *xlindx, | |
50 | 55 | *invp, *cols, *rows, *lindx, *xja; //*t_cols, *t_rows; |
51 | 56 | double *SICH, *MM, *workspaceD, *workspaceU, |
52 | *VT, *work, *w2, *U, *D, *workLU, | |
57 | *VT, *work, *w2, *U, *D, *workLU, *diagonal, | |
53 | 58 | *lnz, *DD, *w3, *result, |
54 | 59 | *to_be_deleted; //, *t_DD; |
55 | 60 | } solve_storage; |
56 | 61 | |
57 | ||
58 | ||
59 | ||
62 | #define SOLVE 0 | |
63 | #define MATRIXSQRT 1 | |
64 | #define DETERMINANT 2 | |
60 | 65 | |
61 | 66 | #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 |
4 | 4 | Martin Schlather, schlather@math.uni-mannheim.de |
5 | 5 | |
6 | 6 | |
7 | Copyright (C) 2015 Martin Schlather | |
7 | Copyright (C) 2015 -- 2017 Martin Schlather | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
31 | 31 | #define NOERROR 0 |
32 | 32 | #define ERRORMEMORYALLOCATION 1 |
33 | 33 | #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 */ | |
37 | 37 | |
38 | 38 | |
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 | |
47 | 41 | #define MAXERRORSTRING 1000 |
48 | 42 | #define nErrorLoc 1000 |
49 | #define LENERRMSG 2000 | |
43 | #define LENERRMSG 1000 | |
50 | 44 | typedef char errorstring_type[MAXERRORSTRING]; |
51 | 45 | 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 | |
52 | 66 | 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 | |
55 | 67 | 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 | |
57 | 71 | 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] | |
60 | 102 | |
61 | 103 | |
62 | 104 | #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)} | |
115 | 180 | |
116 | 181 | #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 | ||
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 |
5 | 5 | Martin Schlather, schlather@math.uni-mannheim.de |
6 | 6 | |
7 | 7 | |
8 | Copyright (C) 2015 Martin Schlather | |
8 | Copyright (C) 2015 -- 2017 Martin Schlather | |
9 | 9 | |
10 | 10 | This program is free software; you can redistribute it and/or |
11 | 11 | modify it under the terms of the GNU General Public License |
27 | 27 | #ifndef kleinkram_rfutils_h |
28 | 28 | #define kleinkram_rfutils_h 1 |
29 | 29 | |
30 | #include "Basic_utils.h" | |
31 | ||
30 | #include <R.h> | |
31 | #include <Rinternals.h> | |
32 | #include "Basic_utils.h" //#include "local1.h" | |
32 | 33 | |
33 | 34 | typedef char name_type[][MAXCHAR]; |
34 | 35 | |
35 | 36 | void strcopyN(char *dest, const char *src, int n); |
36 | 37 | |
37 | 38 | usr_bool UsrBool(SEXP p, char *name, int idx); |
39 | usr_bool UsrBoolRelaxed(SEXP p, char *name, int idx); | |
38 | 40 | |
39 | 41 | #define INT Integer(el, name, 0) |
40 | #define LOG Logical(el, name, 0) | |
42 | #define LOGI Logical(el, name, 0) | |
41 | 43 | #define NUM Real(el, name, 0) |
42 | 44 | #define USRLOG UsrBool(el, name, 0) |
45 | #define USRLOGRELAXED UsrBoolRelaxed(el, name, 0) | |
43 | 46 | #define CHR Char(el, name) |
44 | 47 | #define STR(X, N) strcopyN(X, CHAR(STRING_ELT(el, 0)), N); |
45 | 48 | #define POS0INT NonNegInteger(el, name) /* better: non-negative */ |
57 | 60 | SEXP Mat(double* V, int row, int col, int max); |
58 | 61 | SEXP Mat_t(double* V, int row, int col, int max); |
59 | 62 | SEXP MatInt(int* V, int row, int col, int max) ; |
63 | SEXP MatString(char **V, int row, int col, int max); | |
60 | 64 | SEXP Array3D(int** V, int depth, int row, int col, int max) ; |
61 | 65 | SEXP String(char *V); |
62 | 66 | |
67 | 71 | SEXP Mat(double* V, int row, int col); |
68 | 72 | SEXP Mat_t(double* V, int row, int col); |
69 | 73 | SEXP MatInt(int* V, int row, int col) ; |
74 | SEXP MatString(char** V, int row, int col); | |
70 | 75 | SEXP Array3D(int** V, int depth, int row, int col) ; |
71 | 76 | SEXP String(char V[][MAXCHAR], int n, int max); |
72 | 77 | SEXP String(int *V, const char * List[], int n, int endvalue); |
102 | 107 | |
103 | 108 | |
104 | 109 | SEXP ExtendedInteger(double x); |
105 | SEXP ExtendedBoolean(double x); | |
106 | 110 | SEXP ExtendedBooleanUsr(usr_bool x); |
107 | 111 | |
108 | 112 | |
111 | 115 | void XCXt(double *X, double *C, double *V, int nrow, int dim); |
112 | 116 | void AtA(double *a, int nrow, int ncol, double *A); |
113 | 117 | 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); | |
114 | 119 | void xA(double *x1, double *x2, double*A, int nrow, int ncol, double *y1, |
115 | 120 | double *y2); |
121 | void xAx(double *x, double*A, int nrow, double *y); | |
116 | 122 | void Ax(double *A, double*x, int nrow, int ncol, double *y); |
117 | 123 | void Ax(double *A, double*x1, double*x2, int nrow, int ncol, double *y1, |
118 | 124 | double *y2); |
124 | 130 | void matmulttransposed(double *A, double *B, double *C, int m, int l, int n); |
125 | 131 | void matmult_2ndtransp(double *A, double *B, double *C, int m, int l, int n); |
126 | 132 | 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); | |
128 | 134 | |
129 | 135 | |
130 | 136 | |
156 | 162 | } |
157 | 163 | |
158 | 164 | double scalar(double *A, double *B, int N); |
165 | double ownround(double x); | |
159 | 166 | |
167 | #define Mod(ZZ, modulus) ((ZZ) - FLOOR((ZZ) / (modulus)) * (modulus)) | |
168 | double lonmod(double x, double modulus); | |
160 | 169 | |
161 | 170 | /* |
162 | 171 | extern "C" void vectordist(double *v, int *dim, double *dist, int *diag); |
163 | 172 | bool is_diag(double *aniso, int dim); |
164 | */ | |
173 | */ | |
165 | 174 | |
166 | 175 | #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 |
5 | 5 | Martin Schlather, schlather@math.uni-mannheim.de |
6 | 6 | |
7 | 7 | |
8 | Copyright (C) 2015 Martin Schlather | |
8 | Copyright (C) 2015 -- 2017 Martin Schlather | |
9 | 9 | |
10 | 10 | This program is free software; you can redistribute it and/or |
11 | 11 | 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 |
15 | 15 | prints the names and the values; for vectors \command{cat} |
16 | 16 | is used and for lists \command{str} |
17 | 17 | } |
18 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
19 | \url{http://ms.math.uni-mannheim.de/de/publications/software}} | |
18 | \me | |
20 | 19 | |
21 | 20 | \keyword{print} |
22 | 21 |
0 | 0 | \name{RFoptions} |
1 | 1 | \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} | |
2 | 10 | \title{Setting control arguments} |
3 | 11 | \description{ |
4 | 12 | \command{\link{RFoptions}} sets and returns control arguments for the analysis |
20 | 28 | The subsections below comment on\cr |
21 | 29 | \bold{1. \code{basic}: Basic options}\cr |
22 | 30 | \bold{2. \code{solve}: Options for solving linear systems}\cr |
31 | \bold{3. Reserved words}\cr | |
32 | \cr | |
23 | 33 | |
24 | 34 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
25 | 35 | % \bold{16. Options for RFloglikelihood}\cr |
30 | 40 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
31 | 41 | \bold{1. Basic options} |
32 | 42 | \describe{ |
33 | \item{asList}{logical. Lists of arguments are treated slightly | |
43 | \item{\code{asList}}{logical. Lists of arguments are treated slightly | |
34 | 44 | different from non-lists. If \code{asList=FALSE} they are treated the |
35 | 45 | same way as non-lists. This options being set to \code{FALSE} after |
36 | 46 | calling \command{RFoptions} it should be set as first element of a list. |
69 | 79 | Default: 1 \cr % [also do].\cr |
70 | 80 | } |
71 | 81 | |
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 | ||
72 | 94 | \item{\code{printlevel}}{If \code{printlevel}\eqn{\le0}{<=0} |
73 | 95 | there is not any output on the screen. The |
74 | 96 | higher the number the more tracing information is given. |
87 | 109 | Default: 1 %[also do].\cr |
88 | 110 | } |
89 | 111 | |
90 | \item{seed}{integer (currently only used by the package RandomFields). | |
112 | \item{\code{seed}}{integer (currently only used by the package | |
113 | RandomFields). | |
91 | 114 | If \code{NULL} or \code{NA} |
92 | 115 | \command{\link[base]{set.seed}} is \bold{not} called. |
93 | 116 | Otherwise, \code{\link[base]{set.seed}(seed)} is set |
135 | 158 | |
136 | 159 | |
137 | 160 | \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 | } | |
138 | 170 | \item{\code{max_chol}}{integer. Maximum number of rows of a matrix in |
139 | 171 | a Cholesky decomposition |
140 | 172 | |
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 | |
144 | 176 | a svd decomposition |
145 | 177 | |
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}}{ | |
150 | 264 | vector of at most 3 integers that gives the sequence of methods |
151 | 265 | in order to inverse a matrix or to calculate its square root: |
152 | 266 | \code{"cholesky"}, \code{"svd"}, \code{"eigen"} \code{"sparse"}, |
166 | 280 | } |
167 | 281 | |
168 | 282 | \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. | |
170 | 285 | |
171 | 286 | Default: 400 |
172 | 287 | } |
178 | 293 | } |
179 | 294 | \item{\code{spam_pivot}}{ |
180 | 295 | 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 | } | |
183 | 301 | See package \code{spam} for details. |
184 | 302 | |
185 | Default: 1 | |
303 | Default: PIVOTSPARSE_MMD | |
186 | 304 | } |
187 | 305 | \item{\code{spam_sample_n}}{ |
188 | 306 | Whether a matrix is sparse or not is tested by a |
206 | 324 | |
207 | 325 | Default: \code{0} |
208 | 326 | } |
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}}{ | |
217 | 328 | Should the package \code{spam} (sparse matrices) |
218 | 329 | be used for matrix calculations? |
219 | 330 | If \code{TRUE} \pkg{spam} is always used. If \code{FALSE}, |
223 | 334 | Default: \code{NA}. |
224 | 335 | } |
225 | 336 | } |
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 | } | |
226 | 369 | } |
227 | 370 | |
228 | 371 | |
232 | 375 | arguments, otherwise. |
233 | 376 | } |
234 | 377 | |
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 | |
239 | 379 | |
240 | 380 | \examples{ |
241 | 381 |
67 | 67 | } |
68 | 68 | |
69 | 69 | } |
70 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
71 | } | |
70 | \me | |
71 | ||
72 | 72 | \keyword{math} |
2 | 2 | \alias{chol} |
3 | 3 | \alias{cholx} |
4 | 4 | \alias{cholPosDef} |
5 | \alias{chol2mv} | |
6 | \alias{tcholRHS} | |
5 | 7 | \title{Cholesky Decomposition of Positive Definite Matrices} |
6 | 8 | \description{ |
7 | This function calculates the Choleskey decomposition of a matrix. | |
9 | This function calculates the Cholesky decomposition of a matrix. | |
8 | 10 | } |
9 | 11 | |
10 | 12 | \usage{ |
11 | 13 | cholx(a) |
14 | chol2mv(C, n) | |
15 | tcholRHS(C, RHS) | |
12 | 16 | %, sparse=NA, method=-1) |
13 | 17 | } |
14 | 18 | \arguments{ |
15 | 19 | \item{a}{a square real-valued positive definite matrix |
16 | 20 | } |
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} | |
17 | 25 | |
18 | 26 | % \item{sparse}{logical or \code{NA}. |
19 | 27 | % If \code{NA} the function determines whether a sparse |
25 | 33 | % } |
26 | 34 | } |
27 | 35 | \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 | ||
29 | 48 | } |
30 | 49 | \details{ |
31 | 50 | If the matrix is diagonal direct calculations are performed. |
39 | 58 | % \references{ See \link[spam]{chol.spam} of the package \pkg{spam} } |
40 | 59 | |
41 | 60 | \seealso{ |
61 | % \link{chol2mv}, \link{tcholRHS} | |
42 | 62 | \link[spam]{chol.spam} in the package \pkg{spam} |
43 | 63 | } |
44 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
45 | } | |
64 | \me | |
46 | 65 | \keyword{math} |
47 | 66 | \examples{ |
48 | 67 | |
66 | 85 | stopifnot(all(abs(C2 - C1) < 10^{-9})) |
67 | 86 | } |
68 | 87 | |
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 | ||
69 | 133 | } |
70 | 134 |
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} |
42 | 42 | \code{file}.lock has been created} |
43 | 43 | } |
44 | 44 | |
45 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
46 | } | |
45 | \me | |
47 | 46 | |
48 | 47 | \examples{ |
49 | 48 | \dontrun{ |
31 | 31 | Stein, M. L. (1999) \emph{Interpolation of Spatial Data.} New York: Springer-Verlag |
32 | 32 | } |
33 | 33 | |
34 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
35 | } | |
34 | \me | |
36 | 35 | \seealso{ |
37 | 36 | For more details see \command{\link[RandomFields]{RMgauss}}. |
38 | 37 | } |
44 | 43 | |
45 | 44 | \examples{ |
46 | 45 | x <- 3 |
47 | stopifnot(gauss(x) == exp(-x^2)) | |
46 | confirm(gauss(x), exp(-x^2)) | |
48 | 47 | } |
24 | 24 | |
25 | 25 | } |
26 | 26 | |
27 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
28 | } | |
27 | \me | |
29 | 28 | |
30 | 29 | |
31 | 30 | \examples{ |
37 | 36 | \keyword{sysdata} |
38 | 37 | \keyword{utilities} |
39 | 38 | |
40 | ||
41 | ||
42 | ||
43 | ||
44 | ||
45 | ||
46 | ||
47 | ||
48 | ||
49 | 39 | % 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⏎ |
82 | 82 | |
83 | 83 | } |
84 | 84 | |
85 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
86 | } | |
85 | \me | |
87 | 86 | |
88 | 87 | \seealso{ |
89 | 88 | \command{\link{nonstwm}} |
97 | 96 | \keyword{math} |
98 | 97 | |
99 | 98 | |
100 | \examples{ | |
101 | confirm <- function(x, y) stopifnot(all.equal(x, y)) | |
102 | ||
99 | \examples{% library(RandomFieldsUtils) | |
103 | 100 | x <- 3 |
104 | 101 | confirm(matern(x, 0.5), exp(-x)) |
105 | 102 | confirm(matern(x, Inf), gauss(x/sqrt(2))) |
51 | 51 | } |
52 | 52 | } |
53 | 53 | |
54 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
55 | } | |
54 | \me | |
56 | 55 | |
57 | 56 | \seealso{ |
58 | 57 | \command{\link{matern}}. |
49 | 49 | system.time(z<-orderx(x, from=1, to=k)) ## much faster |
50 | 50 | stopifnot(all(x[y ]== x[z])) ## same result |
51 | 51 | } |
52 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
53 | } | |
52 | \me | |
54 | 53 | \keyword{univar} |
55 | 54 | \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 |
15 | 15 | \value{ |
16 | 16 | No value is returned. |
17 | 17 | } |
18 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
19 | } | |
18 | \me | |
20 | 19 | |
21 | 20 | \examples{ |
22 | 21 | ## next command waits half a second before returning |
56 | 56 | |
57 | 57 | Else if the matrix is sparse the package \pkg{spam} is used. |
58 | 58 | |
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 | ||
60 | 63 | If it fails, the eigen value decomposition is tried. |
61 | 64 | } |
62 | 65 | |
66 | 69 | \seealso{ |
67 | 70 | \link[spam]{chol.spam} in the package \pkg{spam} |
68 | 71 | } |
69 | \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} | |
70 | } | |
72 | \me | |
71 | 73 | \keyword{math} |
72 | 74 | \examples{ |
73 | if (FALSE) { | |
74 | ## This examples shows that 'solvex' can be much faster than 'solve' | |
75 | % library(RandomFieldsUtils) | |
75 | 76 | |
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) | |
81 | 82 | |
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 | ||
90 | 127 | |
91 | 128 | } |
92 | 129 | |
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 | ||
3 | 0 | /* |
4 | 1 | Authors |
5 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
6 | 3 | |
7 | 4 | |
8 | Copyright (C) 2015 Martin Schlather | |
5 | Copyright (C) 2015 -- 2017 Martin Schlather | |
9 | 6 | |
10 | 7 | This program is free software; you can redistribute it and/or |
11 | 8 | modify it under the terms of the GNU General Public License |
31 | 28 | #endif |
32 | 29 | #include <R.h> |
33 | 30 | #include <Rmath.h> |
31 | #include "AutoRandomFieldsUtils.h" | |
34 | 32 | |
33 | ||
34 | #ifndef DO_PARALLEL_ALREADY_CONSIDERED | |
35 | 35 | |
36 | 36 | #ifdef _OPENMP |
37 | 37 | #define DO_PARALLEL 1 |
40 | 40 | #undef DO_PARALLEL |
41 | 41 | #endif |
42 | 42 | #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 | ||
43 | 58 | |
44 | 59 | #define MULTIMINSIZE(S) ((S) > 20) |
45 | 60 | // #define MULTIMINSIZE(S) false |
52 | 67 | |
53 | 68 | |
54 | 69 | #define DOPRINT true |
55 | // | |
56 | // 1 | |
70 | //// 1 | |
57 | 71 | |
58 | // // 1 | |
72 | ||
59 | 73 | // // 1 |
60 | 74 | |
61 | 75 | |
62 | 76 | #ifdef __cplusplus |
63 | 77 | extern "C" { |
64 | 78 | #endif |
65 | // Fortran Code by Reinhard Furrer | |
66 | 79 | void spamcsrdns_(int*, double *, int *, int*, double*); |
67 | 80 | void spamdnscsr_(int*, int*, double *, int*, double*, int*, int*, double*); |
68 | 81 | void cholstepwise_(int*, int*, double*, int*, int*, int*, int*, int*, |
98 | 111 | #define RF_INF R_PosInf |
99 | 112 | #define T_PI M_2_PI |
100 | 113 | |
101 | #define MAXUNITS 4 | |
102 | #define MAXCHAR 18 // max number of characters for (covariance) names | |
103 | 114 | #define OBSOLETENAME "obsolete" |
104 | #define RFOPTIONS "RFoptions" | |
105 | 115 | |
106 | 116 | #define MAXINT 2147483647 |
117 | #define MININT -2147483647 | |
118 | #define MAXUNSIGNED (MAXINT * 2) + 1 | |
107 | 119 | #define INFDIM MAXINT |
108 | 120 | #define INFTY INFDIM |
109 | ||
110 | 121 | |
111 | 122 | #define LENGTH length // safety, in order not to use LENGTH defined by R |
112 | 123 | #define complex Rcomplex |
138 | 149 | #define MAX(A,B) ((A) > (B) ? (A) : (B)) |
139 | 150 | |
140 | 151 | |
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 | |
144 | 155 | #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 | |
147 | 158 | #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 | |
150 | 161 | #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 | |
152 | 164 | #define SQRT(X) std::sqrt((double) X) |
153 | 165 | #define STRCMP(A, B) std::strcmp(A, B) |
154 | 166 | #define STRCPY(A, B) std::strcpy(A, B) |
155 | #define STRLEN(X) std::strlen(X) | |
167 | #define STRLEN std::strlen | |
156 | 168 | #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 | |
158 | 171 | #define MEMCOPYX std::memcpy |
172 | #define MEMSET std::memset | |
173 | #define AALLOC std::aligned_alloc | |
159 | 174 | #define CALLOCX std::calloc |
160 | 175 | #define MALLOCX std::malloc |
161 | 176 | #define FREEX std::free |
162 | 177 | #define SPRINTF std::sprintf // |
163 | #define ROUND(X) std::round(X) | |
178 | #define ROUND(X) ownround((double) X) | |
164 | 179 | #define TRUNC(X) ftrunc((double) X) // keine Klammern um X! |
165 | 180 | #define QSORT std::qsort |
166 | 181 | |
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 | |
167 | 189 | #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 |
4 | 4 | Martin Schlather, schlather@math.uni-mannheim.de |
5 | 5 | |
6 | 6 | |
7 | Copyright (C) 2015 Martin Schlather | |
7 | Copyright (C) 2015 -- 2017 Martin Schlather | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
34 | 34 | #include "errors_messages.h" |
35 | 35 | #include "kleinkram.h" |
36 | 36 | #include "Solve.h" |
37 | #include "scalar.h" | |
37 | 38 | |
38 | 39 | |
39 | ||
40 | #define DOPRINTF if (DOPRINT) Rprintf | |
41 | #define PRINTF Rprintf | |
42 | #define print PRINTF /* // */ | |
43 | 40 | |
44 | 41 | #ifdef HIDE_UNUSED_VARIABLE |
45 | 42 | #define VARIABLE_IS_NOT_USED __attribute__ ((unused)) |
59 | 56 | #define INTERNAL SERR("Sorry. This functionality does not exist currently. There is work in progress at the moment by the maintainer.") |
60 | 57 | #define assert(X) {} |
61 | 58 | #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 .", \ | |
63 | 60 | __FUNCTION__, __FILE__, __LINE__); \ |
64 | RFERROR(BUG_MSG); \ | |
65 | } | |
61 | } | |
66 | 62 | #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__);} | |
68 | 64 | #define MEMCOPY(A,B,C) MEMCOPYX(A,B,C) |
65 | #define AMALLOC(ELEMENTS, SIZE) AALLOC(SIZE, (SIZE) * (ELEMENTS)) | |
69 | 66 | #define MALLOC MALLOCX |
70 | 67 | #define CALLOC CALLOCX |
68 | #define XCALLOC CALLOCX | |
69 | // | |
71 | 70 | #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;} | |
72 | 72 | #define UNCONDFREE(X) {FREEX(X); (X)=NULL;} |
73 | 73 | #endif // not SCHLATHERS_MACHINE |
74 | 74 | |
79 | 79 | #define MAXALLOC 1e9 |
80 | 80 | |
81 | 81 | // __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__); \ | |
92 | 90 | } |
93 | 91 | #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__);} | |
95 | 93 | #define DO_TESTS true |
96 | 94 | |
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); }) | |
98 | 96 | //#define MEMCOPY(A,B,C) memory_copy(A, B, C) |
99 | 97 | #define MALLOC(X) __extension__ ({assert((X)>0 && (X)<=MAXALLOC); MALLOCX(X);}) |
100 | 98 | #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;} | |
103 | 102 | #endif // SCHLATHERS_MACHINE |
104 | 103 | |
105 | 104 | |
107 | 106 | |
108 | 107 | #ifdef RANDOMFIELDS_DEBUGGING |
109 | 108 | #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);}) | |
111 | 110 | // |
112 | 111 | #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);}) | |
114 | 115 | //#define MALLOC malloc |
115 | 116 | //#define CALLOC calloc |
116 | 117 | |
118 | ||
119 | // note that DEBUGINDOERR is redefined in MachineDebugging.h | |
117 | 120 | #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__); \ | |
120 | 123 | } |
121 | #define DEBUGINFO DOPRINTF("(currently at %s, line %d)\n", __FILE__, __LINE__) | |
124 | #define DEBUGINFO DOPRINTF("(currently at %.50s, line %d)\n", __FILE__, __LINE__) | |
122 | 125 | |
123 | 126 | #else |
124 | 127 | #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);} | |
126 | 129 | #endif |
127 | 130 | |
128 | 131 | |
132 | extern int PLoffset; | |
129 | 133 | #define PL_IMPORTANT 1 |
130 | 134 | #define PL_BRANCHING 2 |
131 | 135 | #define PL_DETAILSUSER 3 |
142 | 146 | #define PL_SUBDETAILS 10 |
143 | 147 | |
144 | 148 | #define MATERN_NU_THRES 100 |
149 | #define BESSEL_NU_THRES 100 | |
150 | #define LOW_MATERN 1e-20 | |
151 | #define LOW_BESSEL 1e-20 | |
145 | 152 | |
146 | 153 | |
147 | 154 | #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) |
4 | 4 | Martin Schlather, schlather@math.uni-mannheim.de |
5 | 5 | |
6 | 6 | |
7 | Copyright (C) 2015 Martin Schlather | |
7 | Copyright (C) 2015 -- 2017 Martin Schlather | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
34 | 34 | |
35 | 35 | #define R_PRINTLEVEL 1 |
36 | 36 | #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; | |
38 | 44 | |
39 | 45 | |
40 | 46 | #define LEN_OPTIONNAME 201 |
41 | 47 | |
42 | #define basicN 7 | |
48 | #define basicN 9 | |
43 | 49 | // IMPORTANT: all names of basic must be at least 3 letters long !!! |
44 | 50 | extern const char *basic[basicN]; |
45 | 51 | typedef struct basic_param { |
46 | bool | |
47 | skipchecks, | |
48 | asList; | |
49 | 52 | int |
50 | 53 | Rprintlevel, |
51 | 54 | Cprintlevel, |
52 | 55 | seed, cores; |
56 | bool skipchecks, asList, kahanCorrection, helpinfo; | |
53 | 57 | } basic_param; |
54 | 58 | #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 \ | |
57 | 61 | } |
58 | 62 | |
59 | 63 | |
60 | #define nr_InversionMethods ((int) Diagonal + 1) | |
61 | #define nr_user_InversionMethods ((int) NoInversionMethod + 1) | |
62 | 64 | extern const char * InversionNames[nr_InversionMethods]; |
63 | 65 | |
64 | #define PIVOT_NONE 0 | |
65 | #define PIVOT_MMD 1 | |
66 | #define PIVOT_RCM 2 | |
67 | 66 | #define SOLVE_SVD_TOL 3 |
68 | #define solveN 12 | |
67 | #define solveN 20 | |
69 | 68 | 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; | |
72 | 73 | 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 | |
75 | 78 | // bool tmp_delete; |
76 | 79 | } solve_param; |
77 | 80 | #ifdef SCHLATHERS_MACHINE |
79 | 82 | #else |
80 | 83 | #define svd_tol_start 0 |
81 | 84 | #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} | |
86 | 93 | extern const char * solve[solveN]; |
87 | 94 | |
88 | 95 | |
93 | 100 | |
94 | 101 | |
95 | 102 | |
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); | |
100 | 108 | #define ADDCHAR(ELT) x[0] = ELT; ADD(ScalarString(mkChar(x))); |
101 | 109 | |
102 | 110 |
3 | 3 | Martin Schlather, schlather@math.uni-mannheim.de |
4 | 4 | |
5 | 5 | |
6 | Copyright (C) 2016 Martin Schlather | |
6 | Copyright (C) 2016 -- 2017 Martin Schlather | |
7 | 7 | |
8 | 8 | This program is free software; you can redistribute it and/or |
9 | 9 | modify it under the terms of the GNU General Public License |
23 | 23 | #include "RandomFieldsUtils.h" |
24 | 24 | #include "General_utils.h" |
25 | 25 | #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; | |
29 | 32 | |
30 | 33 | |
31 | 34 | void setpDef(int VARIABLE_IS_NOT_USED i, |
32 | 35 | int VARIABLE_IS_NOT_USED j, |
33 | 36 | SEXP VARIABLE_IS_NOT_USED el, |
34 | 37 | 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) { | |
36 | 40 | BUG; |
37 | 41 | } |
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) { | |
39 | 44 | BUG; |
40 | 45 | } |
41 | 46 | |
49 | 54 | |
50 | 55 | #define MAXNLIST 5 |
51 | 56 | 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}, | |
53 | 59 | *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}, | |
55 | 62 | ***Allall[MAXNLIST] = { ownall, NULL, NULL, NULL, NULL}; |
56 | 63 | setparameterfct setparam[MAXNLIST] = |
57 | 64 | {setparameterUtils, setpDef, setpDef, setpDef, setpDef}; |
58 | 65 | getparameterfct getparam[MAXNLIST] = |
59 | 66 | {getparameterUtils, getpDef, getpDef, getpDef, getpDef}; |
60 | 67 | 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) { | |
63 | 73 | int |
64 | 74 | j = NOMATCHING, |
65 | 75 | i = NOMATCHING, |
66 | 76 | ListNr = NOMATCHING; |
67 | 77 | char name[LEN_OPTIONNAME]; |
68 | 78 | |
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); | |
72 | 82 | // print("relax=%d\n", RELAX_UNKNOWN_RFOPTION); |
73 | 83 | |
74 | 84 | 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 | } | |
77 | 88 | return; |
78 | 89 | } |
79 | 90 | |
82 | 93 | i = Match(prefix, Allprefix[ListNr], AllprefixN[ListNr]); |
83 | 94 | if (i != NOMATCHING) break; |
84 | 95 | } |
85 | if (i == NOMATCHING) ERR1("option prefix name '%s' not found.", prefix); | |
96 | if (i == NOMATCHING) ERR1("option prefix name '%.50s' not found.", prefix); | |
86 | 97 | if (i < 0 || STRCMP(prefix, Allprefix[ListNr][i])) { |
87 | 98 | for (int k=ListNr + 1; k < NList; k++) { |
88 | 99 | int ii = Match(prefix, Allprefix[ListNr], AllprefixN[ListNr]); |
95 | 106 | } // ii >0 |
96 | 107 | } // for k |
97 | 108 | if (i == MULTIPLEMATCHING) |
98 | ERR1("option prefix name '%s' is ambiguous.", prefix); | |
109 | ERR1("option prefix name '%.50s' is ambiguous.", prefix); | |
99 | 110 | } // prefix == List |
100 | 111 | |
101 | 112 | |
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, | |
103 | 114 | // mainname); |
104 | 115 | |
105 | 116 | j = Match(mainname, Allall[ListNr][i], AllallN[ListNr][i]); |
114 | 125 | } |
115 | 126 | if (j != NOMATCHING) break; |
116 | 127 | } |
117 | if (j==NOMATCHING) ERR1("Unknown option '%s'.", name); | |
128 | if (j==NOMATCHING) ERR1("Unknown option '%.50s'.", name); | |
118 | 129 | |
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"); | |
120 | 131 | |
121 | 132 | if (j < 0 || STRCMP(mainname, Allall[ListNr][i][j])) { |
122 | 133 | int starti = i + 1; |
126 | 137 | int jj = Match(mainname, Allall[k][ii], AllallN[k][ii]); |
127 | 138 | if (jj == NOMATCHING) continue; |
128 | 139 | |
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], | |
130 | 141 | // jj, jj < 0 ? "none" : Allall[k][ii][jj]); |
131 | 142 | j = MULTIPLEMATCHING; |
132 | 143 | if (jj >= 0 && STRCMP(mainname, Allall[k][ii][jj])==0) { |
141 | 152 | } // if j < 0 || != |
142 | 153 | } // no prefix given |
143 | 154 | |
144 | if (j<0) ERR1("Multiple matching for '%s'.", name); | |
155 | if (j<0) ERR1("Multiple matching for '%.50s'.", name); | |
145 | 156 | |
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) { | |
156 | 186 | 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; | |
162 | 190 | 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++) { | |
165 | 193 | totalN += STRCMP(Allprefix[ListNr][i], OBSOLETENAME) != 0; |
166 | 194 | } |
167 | 195 | } |
169 | 197 | PROTECT(list = allocVector(VECSXP, totalN)); |
170 | 198 | PROTECT(names = allocVector(STRSXP, totalN)); |
171 | 199 | |
172 | SEXP *sublist, *subnames; | |
173 | sublist = (SEXP *) MALLOC(sizeof(SEXP) * totalN); | |
174 | subnames = (SEXP *) MALLOC(sizeof(SEXP) * totalN); | |
175 | 200 | for (ListNr =0; ListNr<NList; ListNr++) { |
176 | 201 | //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++) { | |
179 | 204 | if (STRCMP(Allprefix[ListNr][i], OBSOLETENAME) == 0) continue; |
205 | SET_VECTOR_ELT(list, itot, getRFoptions(ListNr, i, local)); | |
180 | 206 | 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); | |
200 | 213 | |
201 | 214 | return list; |
202 | 215 | } |
203 | 216 | |
204 | 217 | |
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) { | |
206 | 269 | int i, len; |
207 | 270 | char prefix[LEN_OPTIONNAME / 2], mainname[LEN_OPTIONNAME / 2]; |
208 | 271 | // printf("splitandset\n"); |
209 | len = strlen(name); | |
272 | len = STRLEN(name); | |
210 | 273 | 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); } | |
212 | 275 | if (i==len) { |
213 | strcpy(prefix, ""); | |
276 | STRCPY(prefix, ""); | |
214 | 277 | strcopyN(mainname, name, LEN_OPTIONNAME / 2); |
215 | 278 | } else { |
216 | 279 | 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) ); | |
218 | 281 | } |
219 | 282 | |
220 | 283 | // |
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); | |
223 | 287 | // printf("ende\n"); |
224 | 288 | } |
225 | 289 | |
226 | 290 | |
227 | 291 | 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; | |
230 | 295 | char *name, *pref; |
231 | 296 | bool isList = false; |
232 | /* | |
297 | int | |
298 | local = isGLOBAL; | |
299 | ||
300 | ||
301 | /* | |
233 | 302 | In case of strange values of a parameter, undelete |
234 | 303 | the comment for PRINTF |
235 | 304 | */ |
236 | 305 | |
237 | 306 | |
238 | // PRINTF("start %f\n", GLOBAL.gauss.exactness); | |
307 | // PRINTF("start %10g\n", GLOBAL.gauss.exactness); | |
239 | 308 | 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 | ||
246 | 321 | if ((isList = STRCMP(name, "LIST")==0)) { |
247 | 322 | //printf("isList\n"); |
323 | int n_protect = 1; | |
248 | 324 | list = CAR(options); |
249 | 325 | 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)); | |
252 | 328 | lenlist = length(list); |
253 | 329 | for (i=0; i<lenlist; i++) { |
254 | 330 | int len; |
255 | 331 | pref = (char*) CHAR(STRING_ELT(names, i)); |
256 | 332 | |
257 | // print("%d %s\n", i, pref); | |
333 | // print("%d %.50s\n", i, pref); | |
258 | 334 | |
259 | 335 | sublist = VECTOR_ELT(list, i); |
260 | len = strlen(pref); | |
336 | len = STRLEN(pref); | |
261 | 337 | for (j=0; j < len && pref[j]!='.'; j++); |
262 | 338 | if (TYPEOF(sublist) == VECSXP && j==len) { // no "." |
263 | 339 | // so, general parameters may not be lists, |
264 | 340 | // others yes |
265 | 341 | lensub = length(sublist); |
266 | subnames = getAttrib(sublist, R_NamesSymbol); | |
342 | PROTECT(subnames = getAttrib(sublist, R_NamesSymbol)); | |
343 | n_protect++; | |
267 | 344 | for (j=0; j<lensub; j++) { |
268 | 345 | name = (char*) CHAR(STRING_ELT(subnames, j)); |
269 | 346 | |
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, | |
273 | 350 | // GLOBAL.gauss.exactness, GLOBAL.TBM.linesimustep); |
274 | 351 | // |
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 | ||
277 | 355 | setparameter(VECTOR_ELT(sublist, j), pref, name, |
278 | isList & GLOBAL.basic.asList); | |
356 | isList & GLOBAL.basic.asList, NULL, local); | |
279 | 357 | } |
358 | UNPROTECT(1); | |
280 | 359 | } else { |
281 | splitAndSet(sublist, pref, isList); | |
360 | splitAndSet(sublist, pref, isList, NULL, local); | |
282 | 361 | } |
283 | 362 | } |
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); | |
290 | 384 | 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); | |
294 | 391 | // print("end2\n"); |
295 | 392 | } |
296 | 393 | |
297 | 394 | |
298 | 395 | //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) { | |
300 | 398 | // 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 | ||
306 | 405 | GLOBAL.basic.asList = true; |
307 | return(R_NilValue); | |
406 | return(ans); | |
308 | 407 | } |
309 | 408 | |
310 | 409 | |
311 | ||
410 | int PLoffset = 0; | |
312 | 411 | 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) { | |
316 | 417 | for (int ListNr=0; ListNr<NList; ListNr++) { |
317 | 418 | if (AllprefixN[ListNr] == N && |
318 | 419 | 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.", | |
321 | 422 | prefixlist[0]); |
423 | } | |
322 | 424 | return; |
323 | 425 | } |
324 | 426 | } |
427 | if (basicopt) basic_options[nbasic_options++] = prefixlist[0]; | |
325 | 428 | if (NList >= MAXNLIST) BUG; |
326 | 429 | Allprefix[NList] = prefixlist; |
327 | 430 | AllprefixN[NList] = N; |
330 | 433 | setparam[NList] = set; |
331 | 434 | finalparam[NList] = final; |
332 | 435 | getparam[NList] = get; |
436 | delparam[NList] = del; | |
333 | 437 | NList++; |
438 | PLoffset = pl_offset; | |
439 | basic_param *gp = &(GLOBAL.basic); | |
440 | PL = gp->Cprintlevel = gp->Rprintlevel + PLoffset; | |
441 | CORES = gp->cores; | |
334 | 442 | } |
335 | 443 | |
336 | 444 | |
342 | 450 | STRCMP(Allprefix[ListNr][0], prefixlist[0]) == 0) break; |
343 | 451 | } |
344 | 452 | 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.", | |
346 | 454 | prefixlist[0]); |
347 | 455 | } |
348 | 456 | |
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 | ||
349 | 464 | for (ListNr++; ListNr<NList; ListNr++) { |
350 | 465 | Allprefix[ListNr - 1] = Allprefix[ListNr]; |
351 | 466 | AllprefixN[ListNr - 1] = AllprefixN[ListNr]; |
357 | 472 | } |
358 | 473 | |
359 | 474 | NList--; |
475 | if (NList <= 1) PLoffset = 0; | |
360 | 476 | } |
361 | 477 | |
362 | 478 | void getUtilsParam(utilsparam **global) { |
5 | 5 | Martin Schlather, schlather@math.uni-mannheim.de |
6 | 6 | |
7 | 7 | |
8 | Copyright (C) 2015 Martin Schlather | |
8 | Copyright (C) 2015 -- 2017 Martin Schlather | |
9 | 9 | |
10 | 10 | This program is free software; you can redistribute it and/or |
11 | 11 | modify it under the terms of the GNU General Public License |
49 | 49 | SEXP RFoptions(SEXP options); |
50 | 50 | void RelaxUnknownRFoption(int *relax); |
51 | 51 | |
52 | SEXP attachRFoptionsUtils(); | |
53 | SEXP detachRFoptionsUtils(); | |
52 | SEXP attachRandomFieldsUtils(SEXP show); | |
53 | SEXP detachRandomFieldsUtils(); | |
54 | 54 | |
55 | 55 | SEXP sortX(SEXP Data, SEXP From, SEXP To, SEXP NAlast); |
56 | 56 | SEXP orderX(SEXP Data, SEXP From, SEXP To, SEXP NAlast); |
60 | 60 | void hostname(char **h, int *i); |
61 | 61 | void pid(int *i); |
62 | 62 | 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 | ||
63 | 75 | |
64 | 76 | |
65 | void Ordering(double *d, int *len, int *dim, int *pos); | |
66 | ||
67 | 77 | #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); | |
74 | 80 | #endif |
75 | 81 | |
76 | 82 | #ifdef __cplusplus |
2 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
3 | 3 | |
4 | 4 | |
5 | Copyright (C) 2015 Martin Schlather | |
5 | Copyright (C) 2015 -- 2017 Martin Schlather | |
6 | 6 | |
7 | 7 | This program is free software; you can redistribute it and/or |
8 | 8 | modify it under the terms of the GNU General Public License |
19 | 19 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
20 | 20 | */ |
21 | 21 | |
22 | ||
22 | #include "errors_messages.h" | |
23 | 23 | |
24 | 24 | #ifndef rfutils_solve_H |
25 | 25 | #define rfutils_solve_H 1 |
33 | 33 | direct_formula, |
34 | 34 | Diagonal // always last one! |
35 | 35 | } InversionMethod; |
36 | #define nr_InversionMethods ((int) Diagonal + 1) | |
37 | #define nr_user_InversionMethods ((int) NoFurtherInversionMethod + 1) | |
36 | 38 | |
37 | 39 | |
38 | 40 | #define SOLVE_METHODS 3 |
39 | 41 | typedef struct solve_storage { |
42 | errorstring_type err_msg; | |
43 | InversionMethod method, newMethods[SOLVE_METHODS]; | |
44 | usr_bool sparse; | |
40 | 45 | 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, | |
42 | 47 | xlnz_n, snode_n, xsuper_n, xlindx_n, invp_n, |
43 | 48 | 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, | |
48 | 53 | *iwork, *ipiv, |
49 | *pivot, *xlnz, *snode, *xsuper, *xlindx, | |
54 | *pivotsparse, *xlnz, *snode, *xsuper, *xlindx, | |
50 | 55 | *invp, *cols, *rows, *lindx, *xja; //*t_cols, *t_rows; |
51 | 56 | double *SICH, *MM, *workspaceD, *workspaceU, |
52 | *VT, *work, *w2, *U, *D, *workLU, | |
57 | *VT, *work, *w2, *U, *D, *workLU, *diagonal, | |
53 | 58 | *lnz, *DD, *w3, *result, |
54 | 59 | *to_be_deleted; //, *t_DD; |
55 | 60 | } solve_storage; |
56 | 61 | |
57 | ||
58 | ||
59 | ||
62 | #define SOLVE 0 | |
63 | #define MATRIXSQRT 1 | |
64 | #define DETERMINANT 2 | |
60 | 65 | |
61 | 66 | #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 | ||
0 | 21 | subroutine backsolve(m,nsuper,nrhs,lindx,xlindx,lnz, |
1 | 22 | & xlnz,xsuper,b) |
2 | 23 | c see below... |
3 | 3 | |
4 | 4 | Collection of system specific auxiliary functions |
5 | 5 | |
6 | Copyright (C) 2001 -- 2015 Martin Schlather, | |
6 | Copyright (C) 2001 -- 2017 Martin Schlather, | |
7 | 7 | |
8 | 8 | This program is free software; you can redistribute it and/or |
9 | 9 | modify it under the terms of the GNU General Public License |
60 | 60 | pois += e; |
61 | 61 | int |
62 | 62 | 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);} | |
64 | 64 | double |
65 | 65 | *field = rf + nloc * (int) (UNIFORM_RANDOM * N), |
66 | 66 | *s2 = sigma2 + x0 * nloc, |
67 | uz0 = - Log(pois) - field[x0]; | |
67 | uz0 = - LOG(pois) - field[x0]; | |
68 | 68 | |
69 | 69 | for (int j=0; j<nloc; j++) { |
70 | 70 | if (j == x0 && field[j] != field[x0]) BUG; |
71 | 71 | 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 | } | |
76 | 78 | if (w > ans[j]) ans[j] = w; |
77 | 79 | } |
78 | 80 | } |
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 | ||
0 | 21 | subroutine updatefactor( m,nnzd, |
1 | 22 | & d,jd,id, invp,perm, |
2 | 23 | & lindx,xlindx, nsuper,lnz,xlnz, |
372 | 393 | C |
373 | 394 | C |
374 | 395 | YOFF1 = 0 |
396 | IY1 = 0 | |
375 | 397 | DO 200 ICOL = 1, Q |
376 | 398 | YCOL = LDA - RELIND(ICOL) |
377 | 399 | LBOT1 = XLNZ(YCOL+1) - 1 |
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 | } |
4 | 4 | Martin Schlather, schlather@math.uni-mannheim.de |
5 | 5 | |
6 | 6 | |
7 | Copyright (C) 2015 Martin Schlather | |
7 | Copyright (C) 2015 -- 2017 Martin Schlather | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
31 | 31 | #define NOERROR 0 |
32 | 32 | #define ERRORMEMORYALLOCATION 1 |
33 | 33 | #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 */ | |
37 | 37 | |
38 | 38 | |
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 | |
47 | 41 | #define MAXERRORSTRING 1000 |
48 | 42 | #define nErrorLoc 1000 |
49 | #define LENERRMSG 2000 | |
43 | #define LENERRMSG 1000 | |
50 | 44 | typedef char errorstring_type[MAXERRORSTRING]; |
51 | 45 | 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 | |
52 | 66 | 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 | |
55 | 67 | 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 | |
57 | 71 | 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] | |
60 | 102 | |
61 | 103 | |
62 | 104 | #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)} | |
115 | 180 | |
116 | 181 | #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 | /* | |
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 | ||
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 |
1 | 1 | Authors |
2 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
3 | 3 | |
4 | Copyright (C) 2015 -- 2016 Martin Schlather, Reinhard Furrer | |
4 | Copyright (C) 2015 -- 2017 Martin Schlather | |
5 | 5 | |
6 | 6 | This program is free software; you can redistribute it and/or |
7 | 7 | modify it under the terms of the GNU General Public License |
19 | 19 | */ |
20 | 20 | |
21 | 21 | #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 | ||
24 | 30 | |
25 | 31 | void strcopyN(char *dest, const char *src, int n) { |
26 | 32 | if (n > 1) { |
30 | 36 | dest[n] = '\0'; |
31 | 37 | } |
32 | 38 | |
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 | ||
41 | 39 | void AtA(double *a, int nrow, int ncol, double *C) { |
42 | 40 | // C = A^T %*% A |
43 | 41 | #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) | |
46 | 43 | #endif |
47 | 44 | for (int i=0; i<ncol; i++) { |
48 | 45 | double |
49 | 46 | *A = a + i * nrow, |
50 | 47 | *B = A; |
51 | 48 | 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); | |
53 | 50 | } |
54 | 51 | } |
55 | 52 | } |
56 | 53 | |
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 | } | |
57 | 65 | |
58 | 66 | void xA(double *x, double*A, int nrow, int ncol, double *y) { |
59 | 67 | if (A == NULL) { |
60 | 68 | if (nrow != ncol || nrow <= 0) BUG; |
61 | 69 | MEMCOPY(y, x, sizeof(double) * nrow); |
62 | 70 | } 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)) | |
76 | 73 | #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 | ||
103 | 78 | void xA(double *x1, double *x2, double*A, int nrow, int ncol, double *y1, |
104 | 79 | double *y2) { |
105 | 80 | if (A == NULL) { |
107 | 82 | MEMCOPY(y1, x1, sizeof(double) * nrow); |
108 | 83 | MEMCOPY(y2, x2, sizeof(double) * nrow); |
109 | 84 | } 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)) | |
112 | 97 | #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 | } | |
123 | 101 | |
124 | 102 | void Ax(double *A, double*x, int nrow, int ncol, double *y) { |
125 | 103 | if (A == NULL) { |
127 | 105 | MEMCOPY(y, x, sizeof(double) * nrow); |
128 | 106 | } else { |
129 | 107 | #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)) | |
131 | 109 | for (int j=0; j<nrow; j++) { |
132 | 110 | double dummy = 0.0; |
133 | 111 | int k = j; |
177 | 155 | int size = nrow * dim; |
178 | 156 | |
179 | 157 | #ifdef DO_PARALLEL |
180 | #pragma omp parallel for reduction(+:result) | |
158 | #pragma omp parallel for num_threads(CORES) reduction(+:result) | |
181 | 159 | #endif |
182 | 160 | for (int j=0; j<size; j+=nrow) { |
183 | 161 | double scalar = 0.0; |
194 | 172 | double |
195 | 173 | *endpX = X + nrow, |
196 | 174 | *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"); | |
198 | 176 | |
199 | 177 | #ifdef DO_PARALLEL |
200 | #pragma omp parallel for | |
178 | #pragma omp parallel for num_threads(CORES) | |
201 | 179 | #endif |
202 | 180 | for (double *pX = X; pX < endpX; pX++) { |
203 | 181 | double *pdummy = dummy + (pX - X); |
212 | 190 | |
213 | 191 | // V = dummy X^t |
214 | 192 | #ifdef DO_PARALLEL |
215 | #pragma omp parallel for | |
193 | #pragma omp parallel for num_threads(CORES) | |
216 | 194 | #endif |
217 | 195 | for (int rv=0; rv<nrow; rv++) { |
218 | 196 | for (int cv=rv; cv<nrow; cv++) { |
233 | 211 | double xVy = 0.0; |
234 | 212 | int dimM1 = dim - 1; |
235 | 213 | #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) | |
237 | 215 | #endif |
238 | 216 | for (int d=0; d<dim; d++) { |
239 | 217 | int i, |
252 | 230 | assert(z != NULL); |
253 | 231 | int dimM1 = dim - 1; |
254 | 232 | #ifdef DO_PARALLEL |
255 | #pragma omp parallel for if (MULTIMINSIZE(dim)) | |
233 | #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(dim)) | |
256 | 234 | #endif |
257 | 235 | for (int d=0; d<dim; d++) { |
258 | 236 | double dummy; |
272 | 250 | double xVx = 0.0; |
273 | 251 | int dimM1 = dim - 1; |
274 | 252 | #ifdef DO_PARALLEL |
275 | #pragma omp parallel for reduction(+:xVx) | |
253 | #pragma omp parallel for num_threads(CORES) reduction(+:xVx) | |
276 | 254 | #endif |
277 | 255 | for (int d=0; d<dim; d++) { |
278 | 256 | int i, |
295 | 273 | double xVx = 0.0; |
296 | 274 | int dimM1 = dim - 1; |
297 | 275 | #ifdef DO_PARALLEL |
298 | #pragma omp parallel for reduction(+:xVx) | |
276 | #pragma omp parallel for num_threads(CORES) reduction(+:xVx) | |
299 | 277 | #endif |
300 | 278 | for (int d=0; d<dim; d++) { |
301 | 279 | int i, |
313 | 291 | void matmult(double *a, double *b, double *c, int l, int m, int n) { |
314 | 292 | // multiplying an lxm- and an mxn-matrix, saving result in C |
315 | 293 | #ifdef DO_PARALLEL |
316 | #pragma omp parallel for | |
294 | #pragma omp parallel for num_threads(CORES) | |
317 | 295 | #endif |
318 | 296 | for (int i=0; i<l; i++) { |
319 | 297 | double *A = a + i, |
332 | 310 | // multiplying t(A) and B with dim(A)=(m,l) and dim(B)=(m,n), |
333 | 311 | // saving result in C |
334 | 312 | #ifdef DO_PARALLEL |
335 | #pragma omp parallel for | |
313 | #pragma omp parallel for num_threads(CORES) | |
336 | 314 | #endif |
337 | 315 | for (int i=0; i<l; i++) { |
338 | 316 | double *C = c + i, |
339 | 317 | *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), | |
348 | 326 | // saving result in C |
349 | 327 | int msq = m * m; |
350 | 328 | #ifdef DO_PARALLEL |
351 | #pragma omp parallel for | |
329 | #pragma omp parallel for num_threads(CORES) if (l * m * n > 1000) | |
352 | 330 | #endif |
353 | 331 | for (int i=0; i<l; i++) { |
354 | 332 | double *C = c + i, |
368 | 346 | // calculating t(A B) with dim(A)=(m,l) and dim(B)=(m,n), |
369 | 347 | // saving result in C |
370 | 348 | #ifdef DO_PARALLEL |
371 | #pragma omp parallel for | |
349 | #pragma omp parallel for num_threads(CORES) | |
372 | 350 | #endif |
373 | 351 | for (int i=0; i<l; i++) { |
374 | 352 | double *A = a + i, |
387 | 365 | void Xmatmult(double *A, double *B, double *C, int l, int m, int n) { |
388 | 366 | // multiplying an lxm- and an mxn-matrix, saving result in C |
389 | 367 | #ifdef DO_PARALLEL |
390 | #pragma omp parallel for | |
368 | #pragma omp parallel for num_threads(CORES) | |
391 | 369 | #endif |
392 | 370 | for (int i=0; i<l; i++) { |
393 | 371 | for (int jl=i, jm=0, j=0; j<n; j++, jl+=l, jm+=m) { |
403 | 381 | // multiplying t(A) and B with dim(A)=(m,l) and dim(B)=(m,n), |
404 | 382 | // saving result in C |
405 | 383 | #ifdef DO_PARALLEL |
406 | #pragma omp parallel for | |
384 | #pragma omp parallel for num_threads(CORES) | |
407 | 385 | #endif |
408 | 386 | for (int i=0; i<l; i++) { |
409 | 387 | int im = i * m; |
574 | 552 | } |
575 | 553 | |
576 | 554 | |
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 | ||
577 | 576 | SEXP MatInt(int* V, int row, int col, int max) { |
578 | 577 | if (V==NULL) return allocMatrix(INTSXP, 0, 0); |
579 | 578 | int n = row * col; |
624 | 623 | |
625 | 624 | |
626 | 625 | |
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 | ||
628 | 633 | usr_bool UsrBool(SEXP p, char *name, int idx) { |
629 | 634 | double dummy = Real(p, name, idx); |
630 | 635 | if (dummy == 0.0) return False; |
631 | 636 | 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); | |
634 | 639 | } |
635 | 640 | |
636 | 641 | |
646 | 651 | |
647 | 652 | SEXP String(char V[][MAXCHAR], int n, int max) { |
648 | 653 | SEXP str; |
649 | if (V==NULL) return allocVector(VECSXP, 0); | |
654 | if (V==NULL) return allocVector(STRSXP, 0); | |
650 | 655 | if (n>max) return TooLarge(&n, 1); |
651 | 656 | if (n<0) return TooSmall(); |
652 | 657 | PROTECT(str = allocVector(STRSXP, n)); |
660 | 665 | |
661 | 666 | SEXP String(int *V, const char * List[], int n, int endvalue) { |
662 | 667 | SEXP str; |
663 | if (V==NULL || n <= 0) return allocVector(VECSXP, 0); | |
668 | if (V==NULL || n <= 0) return allocVector(STRSXP, 0); | |
664 | 669 | int k; |
665 | 670 | for (k=0; k<n; k++) { |
666 | 671 | if (V[k] == endvalue) break; |
667 | 672 | } |
673 | // printf("k=%d, n=%d\n", k, n); | |
668 | 674 | PROTECT(str = allocVector(STRSXP, k)); |
669 | 675 | for (int i=0; i<k; i++) { |
676 | // printf("V[%d]=%d\n", i, V[i]); | |
677 | // printf("%.50s\n", List[V[i]]); | |
670 | 678 | SET_STRING_ELT(str, i, mkChar(List[V[i]])); |
671 | 679 | } |
672 | 680 | UNPROTECT(1); |
673 | 681 | return str; |
674 | 682 | } |
675 | 683 | |
676 | //static int ZZ = 0; | |
677 | 684 | 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));} | |
679 | 686 | if (p != R_NilValue) { |
680 | 687 | assert(idx < length(p)); |
681 | 688 | switch (TYPEOF(p)) { |
682 | 689 | 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]); | |
687 | 696 | default : {} |
688 | 697 | } |
689 | 698 | } |
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)); | |
691 | 701 | return RF_NA; // to avoid warning from compiler |
692 | 702 | } |
693 | 703 | |
695 | 705 | |
696 | 706 | void Real(SEXP el, char *name, double *vec, int maxn) { |
697 | 707 | if (el == R_NilValue) { |
698 | ERR1("'%s' cannot be transformed to double.\n", name); | |
708 | RFERROR1("'%.50s' cannot be transformed to double.\n", name); | |
699 | 709 | } |
700 | 710 | int n = length(el); |
701 | 711 | for (int j=0, i=0; i<maxn; i++) { |
718 | 728 | if (ISNAN(value)) { |
719 | 729 | return NA_INTEGER; |
720 | 730 | } |
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; | |
722 | 735 | else { |
723 | ERR2("%s: integer value expected. Got %e.", name, value); | |
736 | RFERROR2("%.50s: integer value expected. Got %10e.", name, value); | |
724 | 737 | } |
725 | 738 | 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]); | |
727 | 741 | default : {} |
728 | 742 | } |
729 | 743 | } 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)); | |
731 | 745 | return NA_INTEGER; // compiler warning vermeiden |
732 | 746 | } |
733 | 747 | |
738 | 752 | |
739 | 753 | void Integer(SEXP el, char *name, int *vec, int maxn) { |
740 | 754 | if (el == R_NilValue) { |
741 | ERR1("'%s' cannot be transformed to integer.\n",name); | |
755 | RFERROR1("'%.50s' cannot be transformed to integer.\n",name); | |
742 | 756 | } |
743 | 757 | int n = length(el); |
744 | 758 | for (int j=0, i=0; i<maxn; i++) { |
753 | 767 | void Integer2(SEXP el, char *name, int *vec) { |
754 | 768 | int n; |
755 | 769 | 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); | |
757 | 771 | } |
758 | 772 | |
759 | 773 | 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); | |
760 | 776 | if (n==1) vec[1] = vec[0]; |
761 | 777 | 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); | |
763 | 781 | if (n > 2) { |
764 | 782 | int v = vec[0] + 1; |
765 | 783 | 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 | ||
767 | 787 | } |
768 | 788 | } |
769 | 789 | } |
776 | 796 | if (p != R_NilValue) |
777 | 797 | assert(idx < length(p)); |
778 | 798 | 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]; | |
780 | 802 | 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]; | |
782 | 805 | case LGLSXP : return LOGICAL(p)[idx]; |
783 | 806 | default : {} |
784 | 807 | } |
785 | ERR1("'%s' cannot be transformed to logical.\n", name); | |
808 | RFERROR1("'%.50s' cannot be transformed to logical.\n", name); | |
786 | 809 | return NA_LOGICAL; // to avoid warning from compiler |
787 | 810 | } |
788 | 811 | |
794 | 817 | if (type == CHARSXP) return CHAR(el)[0]; |
795 | 818 | if (type == STRSXP) { |
796 | 819 | if (length(el)==1) { |
797 | if (strlen(CHAR(STRING_ELT(el,0))) == 1) | |
820 | if (STRLEN(CHAR(STRING_ELT(el,0))) == 1) | |
798 | 821 | 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) | |
800 | 823 | return '\0'; |
801 | 824 | } |
802 | 825 | } |
803 | 826 | |
804 | 827 | ErrorHandling: |
805 | ERR1("'%s' cannot be transformed to character.\n", name); | |
828 | RFERROR1("'%.50s' cannot be transformed to character.\n", name); | |
806 | 829 | return 0; // to avoid warning from compiler |
807 | 830 | } |
808 | 831 | |
809 | 832 | |
810 | 833 | void String(SEXP el, char *name, char names[][MAXCHAR], int maxlen) { |
811 | 834 | int l = length(el); |
812 | char msg[200]; | |
813 | 835 | SEXPTYPE type; |
814 | 836 | if (el == R_NilValue) goto ErrorHandling; |
815 | 837 | 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); | |
817 | 839 | } |
818 | 840 | type = TYPEOF(el); |
819 | 841 | // printf("type=%d %d %d %d\n", TYPEOF(el), INTSXP, REALSXP, LGLSXP); |
831 | 853 | return; |
832 | 854 | |
833 | 855 | 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); | |
836 | 857 | } |
837 | 858 | |
838 | 859 | |
842 | 863 | num = INT; |
843 | 864 | if (num<0) { |
844 | 865 | 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); | |
846 | 867 | } |
847 | 868 | return num; |
848 | 869 | } |
852 | 873 | num = NUM; |
853 | 874 | if (num<0.0) { |
854 | 875 | 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); | |
856 | 877 | } |
857 | 878 | return num; |
858 | 879 | } |
862 | 883 | num = NUM; |
863 | 884 | if (num>0.0) { |
864 | 885 | 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); | |
866 | 887 | } |
867 | 888 | return num; |
868 | 889 | } |
871 | 892 | int num; |
872 | 893 | num = INT; |
873 | 894 | 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; | |
876 | 898 | } |
877 | 899 | return num; |
878 | 900 | } |
881 | 903 | double num; |
882 | 904 | num = NUM; |
883 | 905 | 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; | |
886 | 909 | } |
887 | 910 | return num; |
888 | 911 | } |
891 | 914 | |
892 | 915 | SEXP ExtendedInteger(double x) { |
893 | 916 | 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); | |
898 | 917 | } |
899 | 918 | |
900 | 919 | SEXP ExtendedBooleanUsr(usr_bool x) { |
908 | 927 | unsigned int ln; |
909 | 928 | int Nr; |
910 | 929 | 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)) { | |
915 | 934 | Nr++; |
916 | 935 | } |
917 | 936 | 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 | |
919 | 938 | return Nr; |
920 | 939 | // a matching function is found. Are there other functions that match? |
921 | 940 | int j; |
923 | 942 | j=Nr+1; // if two or more covariance functions have the same name |
924 | 943 | // the last one is taken |
925 | 944 | while (j<n) { |
926 | while ( (j<n) && strncmp(name, List[j], ln)) {j++;} | |
945 | while ( (j<n) && STRNCMP(name, List[j], ln)) {j++;} | |
927 | 946 | if (j<n) { |
928 | if (ln==strlen(List[j])) { // exactmatching -- take first | |
947 | if (ln==STRLEN(List[j])) { // exactmatching -- take first | |
929 | 948 | return j; |
930 | 949 | } |
931 | 950 | else {multiplematching=true;} |
944 | 963 | unsigned int ln; |
945 | 964 | int Nr; |
946 | 965 | 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]); | |
953 | 972 | Nr++; |
954 | 973 | } |
955 | 974 | 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); | |
958 | 977 | return Nr; |
959 | 978 | } |
960 | 979 | // a matching function is found. Are there other functions that match? |
963 | 982 | j=Nr+1; // if two or more covariance functions have the same name |
964 | 983 | // the last one is taken |
965 | 984 | while (j<n) { |
966 | while ( (j<n) && strncmp(name, List[j], ln)) {j++;} | |
985 | while ( (j<n) && STRNCMP(name, List[j], ln)) {j++;} | |
967 | 986 | if (j<n) { |
968 | if (ln==strlen(List[j])) { // exactmatching -- take first | |
987 | if (ln==STRLEN(List[j])) { // exactmatching -- take first | |
969 | 988 | return j; |
970 | 989 | } |
971 | 990 | else {multiplematching=true;} |
975 | 994 | if (multiplematching) {return MULTIPLEMATCHING;} |
976 | 995 | } else return NOMATCHING; |
977 | 996 | |
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); | |
979 | 998 | |
980 | 999 | return Nr; |
981 | 1000 | } |
991 | 1010 | |
992 | 1011 | if (TYPEOF(el) == NILSXP) goto ErrorHandling; |
993 | 1012 | 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); | |
995 | 1014 | |
996 | 1015 | if (TYPEOF(el) == STRSXP) { |
997 | 1016 | for (k=0; k<len_el; k++) { |
1009 | 1028 | } |
1010 | 1029 | |
1011 | 1030 | ErrorHandling0: |
1012 | SPRINTF(dummy, "'%s': unknown value '%s'. Possible values are:", | |
1031 | SPRINTF(dummy, "'%.50s': unknown value '%.50s'. Possible values are:", | |
1013 | 1032 | name, CHAR(STRING_ELT(el, k))); |
1014 | 1033 | int i; |
1015 | 1034 | 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]); | |
1021 | 1040 | |
1022 | 1041 | ErrorHandling: |
1023 | 1042 | if (defaultvalue >= 0) { |
1026 | 1045 | return; |
1027 | 1046 | } |
1028 | 1047 | |
1029 | ERR1("'%s': no value given.", name); | |
1048 | RFERROR1("'%.50s': no value given.", name); | |
1030 | 1049 | } |
1031 | 1050 | |
1032 | 1051 | int GetName(SEXP el, char *name, const char * List[], int n, |
1042 | 1061 | } |
1043 | 1062 | |
1044 | 1063 | |
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 | } | |
1045 | 1073 | |
1046 | 1074 | /* |
1047 | 1075 | |
1058 | 1086 | x = 1.0 / x; |
1059 | 1087 | } |
1060 | 1088 | while (p != 0) { |
1061 | // printf(" ... %e %d : %e\n" , x, p, res); | |
1089 | // printf(" ... %10e %d : %10e\n" , x, p, res); | |
1062 | 1090 | if (p % 2 == 1) res *= x; |
1063 | 1091 | x *= x; |
1064 | 1092 | p /= 2; |
1098 | 1126 | dim = Dim[0]; |
1099 | 1127 | end = v + Dim[1] * dim; |
1100 | 1128 | |
1101 | // print("%d %d %f %f\n", dim , Dim[0], v, end); | |
1129 | // print("%d %d %10g %10g\n", dim , Dim[0], v, end); | |
1102 | 1130 | |
1103 | 1131 | for (dr=0, v1=v; v1<end; v1+=dim) { // loop is one to large?? |
1104 | 1132 | v2 = v1; |
1112 | 1140 | } |
1113 | 1141 | } |
1114 | 1142 | } |
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 | } | |
1127 | 1143 | |
1128 | 1144 | |
1129 | 1145 | int addressbits(void VARIABLE_IS_NOT_USED *addr) { |
5 | 5 | Martin Schlather, schlather@math.uni-mannheim.de |
6 | 6 | |
7 | 7 | |
8 | Copyright (C) 2015 Martin Schlather | |
8 | Copyright (C) 2015 -- 2017 Martin Schlather | |
9 | 9 | |
10 | 10 | This program is free software; you can redistribute it and/or |
11 | 11 | modify it under the terms of the GNU General Public License |
27 | 27 | #ifndef kleinkram_rfutils_h |
28 | 28 | #define kleinkram_rfutils_h 1 |
29 | 29 | |
30 | #include "Basic_utils.h" | |
31 | ||
30 | #include <R.h> | |
31 | #include <Rinternals.h> | |
32 | #include "Basic_utils.h" //#include <Basic_utils.h> | |
32 | 33 | |
33 | 34 | typedef char name_type[][MAXCHAR]; |
34 | 35 | |
35 | 36 | void strcopyN(char *dest, const char *src, int n); |
36 | 37 | |
37 | 38 | usr_bool UsrBool(SEXP p, char *name, int idx); |
39 | usr_bool UsrBoolRelaxed(SEXP p, char *name, int idx); | |
38 | 40 | |
39 | 41 | #define INT Integer(el, name, 0) |
40 | #define LOG Logical(el, name, 0) | |
42 | #define LOGI Logical(el, name, 0) | |
41 | 43 | #define NUM Real(el, name, 0) |
42 | 44 | #define USRLOG UsrBool(el, name, 0) |
45 | #define USRLOGRELAXED UsrBoolRelaxed(el, name, 0) | |
43 | 46 | #define CHR Char(el, name) |
44 | 47 | #define STR(X, N) strcopyN(X, CHAR(STRING_ELT(el, 0)), N); |
45 | 48 | #define POS0INT NonNegInteger(el, name) /* better: non-negative */ |
57 | 60 | SEXP Mat(double* V, int row, int col, int max); |
58 | 61 | SEXP Mat_t(double* V, int row, int col, int max); |
59 | 62 | SEXP MatInt(int* V, int row, int col, int max) ; |
63 | SEXP MatString(char **V, int row, int col, int max); | |
60 | 64 | SEXP Array3D(int** V, int depth, int row, int col, int max) ; |
61 | 65 | SEXP String(char *V); |
62 | 66 | |
67 | 71 | SEXP Mat(double* V, int row, int col); |
68 | 72 | SEXP Mat_t(double* V, int row, int col); |
69 | 73 | SEXP MatInt(int* V, int row, int col) ; |
74 | SEXP MatString(char** V, int row, int col); | |
70 | 75 | SEXP Array3D(int** V, int depth, int row, int col) ; |
71 | 76 | SEXP String(char V[][MAXCHAR], int n, int max); |
72 | 77 | SEXP String(int *V, const char * List[], int n, int endvalue); |
102 | 107 | |
103 | 108 | |
104 | 109 | SEXP ExtendedInteger(double x); |
105 | SEXP ExtendedBoolean(double x); | |
106 | 110 | SEXP ExtendedBooleanUsr(usr_bool x); |
107 | 111 | |
108 | 112 | |
111 | 115 | void XCXt(double *X, double *C, double *V, int nrow, int dim); |
112 | 116 | void AtA(double *a, int nrow, int ncol, double *A); |
113 | 117 | 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); | |
114 | 119 | void xA(double *x1, double *x2, double*A, int nrow, int ncol, double *y1, |
115 | 120 | double *y2); |
121 | void xAx(double *x, double*A, int nrow, double *y); | |
116 | 122 | void Ax(double *A, double*x, int nrow, int ncol, double *y); |
117 | 123 | void Ax(double *A, double*x1, double*x2, int nrow, int ncol, double *y1, |
118 | 124 | double *y2); |
124 | 130 | void matmulttransposed(double *A, double *B, double *C, int m, int l, int n); |
125 | 131 | void matmult_2ndtransp(double *A, double *B, double *C, int m, int l, int n); |
126 | 132 | 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); | |
128 | 134 | |
129 | 135 | |
130 | 136 | |
156 | 162 | } |
157 | 163 | |
158 | 164 | double scalar(double *A, double *B, int N); |
165 | double ownround(double x); | |
159 | 166 | |
167 | #define Mod(ZZ, modulus) ((ZZ) - FLOOR((ZZ) / (modulus)) * (modulus)) | |
168 | double lonmod(double x, double modulus); | |
160 | 169 | |
161 | 170 | /* |
162 | 171 | extern "C" void vectordist(double *v, int *dim, double *dist, int *diag); |
163 | 172 | bool is_diag(double *aniso, int dim); |
164 | */ | |
173 | */ | |
165 | 174 | |
166 | 175 | #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 |
1 | 1 | Authors |
2 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
3 | 3 | |
4 | Copyright (C) 2015 -- Martin Schlather | |
4 | Copyright (C) 2015 -- 2017 Martin Schlather | |
5 | 5 | |
6 | 6 | This program is free software; you can redistribute it and/or |
7 | 7 | modify it under the terms of the GNU General Public License |
19 | 19 | */ |
20 | 20 | #include <R_ext/Lapack.h> |
21 | 21 | #include "RandomFieldsUtils.h" |
22 | #include "init_RandomFieldsUtils.h" | |
22 | #include "zzz_RandomFieldsUtils.h" | |
23 | 23 | #include "General_utils.h" |
24 | 24 | |
25 | 25 | |
29 | 29 | if (x <= 0.0) return RF_NA; // not programmed yet |
30 | 30 | double exp_dummy, |
31 | 31 | dummy = 0.0, |
32 | logx = 2.0 * Log(0.5 * x), | |
32 | logx = 2.0 * LOG(0.5 * x), | |
33 | 33 | x1 = 1.5, |
34 | 34 | x2 = nu + 1.5, |
35 | 35 | value = 1.0, |
38 | 38 | |
39 | 39 | |
40 | 40 | do { |
41 | dummy += logx - Log(x1) - Log(FABS(x2)); | |
41 | dummy += logx - LOG(x1) - LOG(FABS(x2)); | |
42 | 42 | exp_dummy = EXP(dummy); |
43 | 43 | 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); | |
45 | 45 | x1 += 1.0; |
46 | 46 | x2 += 1.0; |
47 | 47 | fsign = factor_Sign * fsign; |
199 | 199 | /* Gausian model */ |
200 | 200 | double Gauss(double x) { |
201 | 201 | return EXP(- x * x); |
202 | // printf("%f %f\n", *x, *v); | |
202 | // printf("%10g %10g\n", *x, *v); | |
203 | 203 | } |
204 | 204 | double logGauss(double x) { |
205 | 205 | return - x * x; |
230 | 230 | double logWM(double x, double nu1, double nu2, double factor) { |
231 | 231 | // check calling functions, like hyperbolic and gneiting if any changings !! |
232 | 232 | |
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 | |
235 | 238 | static double loggamma, loggamma1old, loggamma2old, loggamma_old, |
236 | 239 | nuOld=-RF_INF, |
237 | 240 | nu1old=-RF_INF, |
238 | nu2old=-RF_INF | |
239 | ; | |
241 | nu2old=-RF_INF; | |
242 | #endif | |
240 | 243 | double v, y, |
241 | 244 | nu = 0.5 * (nu1 + nu2), |
242 | 245 | 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); | |
244 | 248 | bool simple = nu1 == nu2 || nu > MATERN_NU_THRES; |
249 | double bk[MATERN_NU_THRES + 1L]; | |
245 | 250 | |
246 | 251 | 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 | |
247 | 256 | if (simple) { |
248 | 257 | if (nuThres != nuOld) { |
249 | 258 | nuOld = nuThres; |
261 | 270 | } |
262 | 271 | loggamma = 0.5 * (loggamma1old + loggamma2old); |
263 | 272 | } |
273 | #endif | |
274 | ||
264 | 275 | 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; | |
267 | 278 | } else v = 0.0; |
268 | 279 | |
269 | 280 | if (nu > MATERN_NU_THRES) { // factor!=0.0 && |
272 | 283 | y = x * factor / 2; |
273 | 284 | w = logGauss(y); |
274 | 285 | |
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); | |
276 | 287 | |
277 | 288 | v = v * g + (1.0 - g) * w; |
278 | 289 | if (nu1 != nu2) { // consistenz zw. nu1, nu2 und nuThres wiederherstellen |
281 | 292 | |
282 | 293 | // if (!R_FINITE(v)) ERR("non-finite value in the whittle-matern model -- value of 'nu' is much too large"); |
283 | 294 | |
284 | //if (nu>100) printf("v=%f \n", v); | |
295 | //if (nu>100) printf("v=%10g \n", v); | |
285 | 296 | } |
286 | 297 | |
287 | 298 | return v; |
294 | 305 | } |
295 | 306 | |
296 | 307 | double DWM(double x, double nu, double factor) { |
308 | #ifdef DO_PARALLEL | |
309 | double loggamma; | |
310 | #else | |
297 | 311 | static double nuOld=RF_INF; |
298 | 312 | static double loggamma; |
313 | #endif | |
299 | 314 | double y, v, |
300 | 315 | 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]; | |
302 | 319 | |
303 | 320 | if (x > LOW_MATERN) { |
304 | if (nuThres!=nuOld) { | |
321 | #ifdef DO_PARALLEL | |
322 | loggamma = lgammafn(nuThres); | |
323 | #else | |
324 | if (nuThres!=nuOld) { | |
305 | 325 | nuOld = nuThres; |
306 | 326 | loggamma = lgammafn(nuThres); |
307 | 327 | } |
328 | #endif | |
308 | 329 | 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); | |
311 | 332 | } else { |
312 | 333 | v = (nuThres > 0.5) ? 0.0 : (nuThres < 0.5) ? INFTY : 1.253314137; |
313 | 334 | } |
325 | 346 | } |
326 | 347 | |
327 | 348 | double DDWM(double x, double nu, double factor) { |
349 | #ifdef DO_PARALLEL | |
350 | double gamma; | |
351 | #else | |
328 | 352 | static double nuOld=RF_INF; |
329 | 353 | static double gamma; |
354 | #endif | |
330 | 355 | double y, v, |
331 | 356 | 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 | ||
335 | 362 | if (x > LOW_MATERN) { |
363 | #ifdef DO_PARALLEL | |
364 | gamma = gammafn(nuThres); | |
365 | #else | |
336 | 366 | if (nuThres!=nuOld) { |
337 | 367 | nuOld = nuThres; |
338 | 368 | gamma = gammafn(nuThres); |
339 | 369 | } |
370 | #endif | |
340 | 371 | y = x * scale; |
341 | 372 | 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)); | |
343 | 375 | } else { |
344 | 376 | v = (nu > 1.0) ? -0.5 / (nu - 1.0) : INFTY; |
345 | 377 | } |
358 | 390 | } |
359 | 391 | |
360 | 392 | double D3WM(double x, double nu, double factor) { |
393 | #ifdef DO_PARALLEL | |
394 | double gamma; | |
395 | #else | |
361 | 396 | static double nuOld=RF_INF; |
362 | 397 | static double gamma; |
398 | #endif | |
363 | 399 | double y, v, |
364 | 400 | nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES, |
365 | 401 | scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0, |
366 | 402 | scaleSq = scale * scale; |
367 | ||
403 | double bk[MATERN_NU_THRES + 1L]; | |
404 | ||
368 | 405 | if (x > LOW_MATERN) { |
406 | #ifdef DO_PARALLEL | |
407 | gamma = gammafn(nuThres); | |
408 | #else | |
369 | 409 | if (nuThres!=nuOld) { |
370 | 410 | nuOld = nuThres; |
371 | 411 | gamma = gammafn(nuThres); |
372 | 412 | } |
413 | #endif | |
373 | 414 | y = x * scale; |
374 | 415 | 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)); | |
377 | 418 | } else { |
378 | 419 | v = 0.0; |
379 | 420 | } |
392 | 433 | } |
393 | 434 | |
394 | 435 | double D4WM(double x, double nu, double factor) { |
395 | static double nuOld=RF_INF; | |
396 | static double gamma; | |
397 | 436 | double y, v, |
398 | 437 | nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES, |
399 | 438 | scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0, |
400 | 439 | 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); | |
403 | 443 | |
404 | 444 | 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; | |
405 | 450 | if (nuThres!=nuOld) { |
406 | 451 | nuOld = nuThres; |
407 | 452 | gamma = gammafn(nuThres); |
408 | 453 | } |
454 | #endif | |
409 | 455 | y = x * scale; |
410 | 456 | 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)); | |
413 | 459 | } 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)); | |
415 | 462 | } |
416 | 463 | v *= scaleSq * scaleSq; |
417 | 464 | |
425 | 472 | v = v * g + (1.0 - g) * w; |
426 | 473 | } |
427 | 474 | |
428 | // printf("v=%f\n", v); | |
475 | // printf("v=%10g\n", v); | |
429 | 476 | |
430 | 477 | return v; |
431 | 478 | } |
499 | 546 | double incomplete_gamma(double start, double end, double s) { |
500 | 547 | // int_start^end t^{s-1} e^{-t} \D t |
501 | 548 | |
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); | |
503 | 550 | |
504 | 551 | double |
505 | 552 | v = 0.0, |
528 | 575 | w = pgamma(start, s, 1.0, 0, 0); // q, shape, scale, lower, log |
529 | 576 | if (R_FINITE(end)) w -= pgamma(end, s, 1.0, 0, 0); |
530 | 577 | |
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); | |
532 | 579 | |
533 | 580 | return v + gammafn(s) * w * factor; |
534 | 581 | } |
3 | 3 | Martin Schlather, schlather@math.uni-mannheim.de |
4 | 4 | |
5 | 5 | |
6 | Copyright (C) 2016 Martin Schlather | |
6 | Copyright (C) 2016 -- 2017 Martin Schlather | |
7 | 7 | |
8 | 8 | This program is free software; you can redistribute it and/or |
9 | 9 | modify it under the terms of the GNU General Public License |
24 | 24 | #ifdef DO_PARALLEL |
25 | 25 | #include <omp.h> |
26 | 26 | #endif |
27 | #include <unistd.h> | |
27 | 28 | #include "General_utils.h" |
28 | 29 | #include "kleinkram.h" |
29 | #include "init_RandomFieldsUtils.h" | |
30 | #include <unistd.h> | |
30 | #include "zzz_RandomFieldsUtils.h" | |
31 | 31 | |
32 | 32 | #define PLverbose 2 |
33 | 33 | |
34 | 34 | // IMPORTANT: all names of general must be at least 3 letters long !!! |
35 | 35 | const char *basic[basicN] = |
36 | { "printlevel", "skipchecks", "cPrintlevel", "seed", "asList", "cores", | |
37 | "verbose"}; | |
36 | { "printlevel","cPrintlevel", "seed", "cores", "skipchecks", "asList", | |
37 | "verbose", "kahanCorrection", "helpinfo"}; | |
38 | 38 | |
39 | 39 | 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" | |
43 | 46 | //, "tmp_delete" |
44 | 47 | }; |
45 | 48 | |
50 | 53 | int ownallN[ownprefixN] = {basicN, solveN}; |
51 | 54 | |
52 | 55 | |
53 | int PL=C_PRINTLEVEL; | |
56 | int PL = C_PRINTLEVEL, | |
57 | CORES = 1; | |
54 | 58 | |
55 | 59 | utilsparam GLOBAL = { |
56 | 60 | basic_START, |
59 | 63 | |
60 | 64 | |
61 | 65 | |
62 | #if defined(unix) || defined(__unix__) || defined(__unix) | |
66 | //#if defined(unix) || defined(__unix__) || defined(__unix) | |
67 | #if defined (__unix__) || (defined (__APPLE__) && defined (__MACH__)) | |
63 | 68 | int numCPU = sysconf(_SC_NPROCESSORS_ONLN); |
64 | 69 | #else |
65 | 70 | int numCPU = MAXINT; |
68 | 73 | |
69 | 74 | |
70 | 75 | 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; | |
72 | 81 | switch(i) { |
73 | 82 | case 0: {// general |
74 | basic_param *gp; | |
75 | gp = &(GLOBAL.basic); | |
83 | basic_param *gp = &(options->basic); | |
76 | 84 | switch(j) { |
77 | 85 | case 0: { // general options |
78 | 86 | int threshold = 1000; //PL_ERRORS; |
79 | 87 | 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; | |
82 | 90 | } |
83 | 91 | 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; | |
89 | 96 | if (gp->cores > numCPU) { |
90 | 97 | WARN1("number of 'cores' is set to %d", numCPU); |
91 | 98 | gp->cores = numCPU; |
92 | 99 | } |
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 | } | |
98 | 105 | #endif |
99 | 106 | break; |
107 | case 4: gp->skipchecks = LOGI; break; | |
108 | case 5: gp->asList = LOGI; break; | |
100 | 109 | case 6 : if (!isList) { |
101 | PL = gp->Cprintlevel = gp->Rprintlevel = (LOG) * PLverbose; | |
110 | PL = gp->Cprintlevel = gp->Rprintlevel = 1 + (LOGI * (PLverbose - 1)); | |
102 | 111 | } |
103 | 112 | break; |
104 | default: BUG; | |
113 | case 7: gp->kahanCorrection = LOGI; break; | |
114 | case 8: gp->helpinfo = LOGI; break; | |
115 | default: BUG; | |
105 | 116 | }} |
106 | 117 | break; |
107 | 118 | |
108 | 119 | case 1: { |
109 | solve_param *so = &(GLOBAL.solve); | |
120 | // printf("name = %.50s %d\n", name, j); | |
121 | ||
122 | solve_param *so = &(options->solve); | |
110 | 123 | 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?? | |
116 | 125 | case 1: so->spam_tol = POS0NUM; break; |
117 | 126 | case 2: so->spam_min_p = POS0NUM; break; |
118 | 127 | 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, | |
120 | 131 | (int) NoInversionMethod, (int) NoFurtherInversionMethod, |
121 | 132 | (int *)so->Methods, SOLVE_METHODS); |
122 | 133 | 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; | |
128 | 139 | 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; | |
134 | 167 | }} |
135 | 168 | break; |
136 | 169 | |
137 | 170 | default: BUG; |
138 | 171 | } |
139 | 172 | |
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; | |
145 | 180 | //#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 : { | |
147 | 187 | // printf("OK %d\n", i); |
148 | k = 0; | |
149 | basic_param *p = &(GLOBAL.basic); | |
188 | basic_param *p = &(options->basic); | |
150 | 189 | ADD(ScalarInteger(p->Rprintlevel)); |
190 | ADD(ScalarInteger(p->Cprintlevel - PLoffset)); | |
191 | ADD(ScalarInteger(p->seed)); | |
192 | ADD(ScalarInteger(p->cores)); | |
151 | 193 | ADD(ScalarLogical(p->skipchecks)); |
152 | ADD(ScalarInteger(p->Cprintlevel)); | |
153 | ADD(ScalarInteger(p->seed)); | |
154 | 194 | 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; | |
158 | 200 | |
159 | i++; { | |
160 | k = 0; | |
161 | solve_param *p = &(GLOBAL.solve); | |
201 | case 1 : { | |
202 | solve_param *p = &(options->solve); | |
162 | 203 | // printf("sparse user interface %d %d; %d %d\n", p->sparse, ExtendedBoolean(p->sparse), NA_LOGICAL, NA_INTEGER); |
163 | 204 | ADD(ExtendedBooleanUsr(p->sparse)); |
164 | 205 | ADD(ScalarReal(p->spam_tol)); |
165 | 206 | ADD(ScalarReal(p->spam_min_p)); |
166 | 207 | ADD(ScalarReal(p->svd_tol)); |
167 | SET_VECTOR_ELT(sublist[i], k++, | |
208 | ADD(ScalarReal(p->eigen2zero)); | |
209 | SET_VECTOR_ELT(sublist, k++, | |
168 | 210 | String((int*) p->Methods, InversionNames, SOLVE_METHODS, |
169 | 211 | (int) NoFurtherInversionMethod)); |
170 | 212 | ADD(ScalarInteger(p->spam_min_n)); |
171 | 213 | ADD(ScalarInteger(p->spam_sample_n)); |
172 | 214 | ADD(ScalarInteger(p->spam_factor)); |
173 | ADD(ScalarInteger(p->pivot)); | |
215 | ADD(ScalarInteger(p->pivotsparse)); | |
174 | 216 | ADD(ScalarInteger(p->max_chol)); |
175 | 217 | 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)); | |
177 | 223 | // 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 | } | |
184 | 243 | |
185 | 244 | void getErrorString(errorstring_type errorstring){ |
245 | #ifdef DO_PARALLEL | |
246 | STRCPY(errorstring, "error occurred in package RandomFieldsUtils"); | |
247 | #else | |
186 | 248 | 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 | |
190 | 254 | strcopyN(ERROR_LOC, errorloc, nErrorLoc); |
191 | } | |
192 | ||
193 | ||
194 | ||
255 | #endif | |
256 | } | |
257 |
1 | 1 | Authors |
2 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
3 | 3 | |
4 | Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer | |
4 | Copyright (C) 2015 -- 2017 Martin Schlather | |
5 | 5 | |
6 | 6 | This program is free software; you can redistribute it and/or |
7 | 7 | modify it under the terms of the GNU General Public License |
27 | 27 | #include <Rinternals.h> |
28 | 28 | #include "General_utils.h" |
29 | 29 | #include "own.h" |
30 | #include "init_RandomFieldsUtils.h" | |
30 | #include "zzz_RandomFieldsUtils.h" | |
31 | #include "Utils.h" | |
31 | 32 | |
32 | 33 | |
33 | 34 | |
34 | 35 | // 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]; | |
38 | 39 | errorloc_type ERROR_LOC=""; |
39 | 40 | errorstring_type ERRORSTRING; |
41 | #endif | |
40 | 42 | |
41 | 43 | |
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]) { | |
50 | 52 | #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"); | |
53 | 56 | #endif |
54 | ||
57 | } | |
55 | 58 | return R_NilValue; |
56 | 59 | } |
57 | 60 | |
58 | SEXP detachRFoptionsUtils(){ | |
59 | #ifdef DO_PARALLEL | |
60 | omp_set_num_threads(1); | |
61 | #endif | |
61 | SEXP detachRandomFieldsUtils(){ | |
62 | 62 | detachRFoptions(ownprefixlist, ownprefixN); |
63 | freeGlobals(); | |
63 | 64 | return R_NilValue; |
64 | 65 | } |
4 | 4 | Martin Schlather, schlather@math.uni-mannheim.de |
5 | 5 | |
6 | 6 | |
7 | Copyright (C) 2015 Martin Schlather | |
7 | Copyright (C) 2015 -- 2017 Martin Schlather | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
27 | 27 | #define rfutil_own_H 1 |
28 | 28 | #include "Options_utils.h" |
29 | 29 | |
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); | |
32 | 33 | void set_num_threads(); |
33 | 34 | |
34 | 35 | |
38 | 39 | **ownall[ownprefixN]; |
39 | 40 | extern int ownallN[ownprefixN]; |
40 | 41 | |
42 | #define HELPINFO(M) if (GLOBAL.basic.helpinfo) WARN1("%.50s\nNote that you can unable the above information by 'RFoptions(helpinfo=FALSE)'.\n", M) // | |
41 | 43 | |
42 | 44 | #endif |
43 | 45 |
4 | 4 | |
5 | 5 | Collection of system specific auxiliary functions |
6 | 6 | |
7 | Copyright (C) 2001 -- 2015 Martin Schlather, | |
7 | Copyright (C) 2001 -- 2017 Martin Schlather, | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
30 | 30 | |
31 | 31 | */ |
32 | 32 | |
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> | |
49 | 36 | #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 | ||
50 | 43 | |
51 | 44 | #define Nmodi 9 |
52 | 45 | name_type modi = { "1x1", "2x2", "4x4", "8x8", "near", "simple", "precise", "kahan", "1x1p"}; |
53 | ||
54 | 46 | |
55 | 47 | |
56 | 48 | typedef unsigned int uint32; |
59 | 51 | #define size 8 |
60 | 52 | #define vectorlen (256 / (size * 8)) |
61 | 53 | #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 | |
66 | 75 | #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); | |
81 | 81 | __m256d SET_0(0); |
82 | 82 | double *D = (double *) &sum0; |
83 | 83 | |
84 | if ( len >= vectorlen * repet) { | |
84 | if (len >= atonce) { | |
85 | 85 | __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) { | |
90 | 87 | 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) { | |
116 | 102 | // deutlich genauer zum 0 tarif |
117 | 103 | 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) { | |
127 | 112 | 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) { | |
158 | 131 | int i = 0, |
159 | lenM = len - (repet * vectorlen - 1); | |
132 | lenM = len - (atonce - 1); | |
160 | 133 | __m256d SET_0(0), P_0(0); |
161 | 134 | double *D = (double *) &sum0; |
162 | 135 | |
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) { | |
189 | 181 | int i = 0, |
190 | lenM = len - (repet * vectorlen - 1); | |
182 | lenM = len - (atonce - 1); | |
191 | 183 | __m256d SET_0(0), SET_0(1), P_0(0); |
192 | 184 | double *D = (double *) &sum1; |
193 | ||
194 | if ( len >= vectorlen * repet) { | |
195 | ||
185 | if ( len >= atonce) { | |
196 | 186 | for (; i < lenM; ) { |
197 | 187 | int lenMM = i + vectorlen * (repet * 10 + 1); |
198 | 188 | 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)); | |
200 | 190 | 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); | |
208 | 195 | } |
209 | 196 | } |
210 | 197 | |
211 | 198 | 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 | |
242 | 219 | int i = 0, |
243 | lenM = len - (repet * vectorlen - 1); | |
220 | lenM = len - (atonce - 1); | |
244 | 221 | __m256d SET_0(0), // sum |
245 | SET_0(1), // c | |
222 | SET_0(1), | |
246 | 223 | SET_0(2), // y |
247 | SET_0(3), // t | |
224 | SET_0(3), // t | |
248 | 225 | P_0(0), |
249 | 226 | 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){ | |
281 | 246 | double *endv1 = v1 + N, |
282 | 247 | 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, | |
291 | 267 | 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 | |
294 | 352 | #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 | ||
332 | 376 | |
333 | 377 | SEXP scalarX(SEXP x, SEXP y, SEXP mode) { |
334 | 378 | int len = length(x); |
335 | 379 | 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 | } | |
338 | 386 | SEXP Ans; |
339 | 387 | PROTECT(Ans = allocVector(REALSXP, 1)); |
340 | 388 | 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); | |
374 | 390 | UNPROTECT(1); |
375 | 391 | return Ans; |
376 | 392 | } |
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 |
1 | 1 | Authors |
2 | 2 | Martin Schlather, schlather@math.uni-mannheim.de |
3 | 3 | |
4 | Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer, Martin Kroll | |
4 | Copyright (C) 2015 -- 2017 Martin Schlather, Reinhard Furrer, Martin Kroll | |
5 | 5 | |
6 | 6 | This program is free software; you can redistribute it and/or |
7 | 7 | modify it under the terms of the GNU General Public License |
23 | 23 | #include <omp.h> |
24 | 24 | #endif |
25 | 25 | #include <R_ext/Lapack.h> |
26 | ||
27 | #define LOCAL_ERRORSTRING | |
28 | #define WHICH_ERRORSTRING pt->err_msg | |
26 | 29 | #include "RandomFieldsUtils.h" |
27 | 30 | #include "own.h" |
28 | #include "init_RandomFieldsUtils.h" | |
31 | #include "zzz_RandomFieldsUtils.h" | |
29 | 32 | #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 | */ | |
30 | 69 | |
31 | 70 | |
32 | 71 | const char * InversionNames[nr_InversionMethods] = { |
33 | "cholesky", "svd", "eigen", "sparse", | |
72 | "cholesky", "svd", "eigen", "sparse", | |
34 | 73 | "method undefined", |
35 | 74 | "qr", "lu", |
36 | "no method left", "direct formula", "diagonal"}; | |
75 | "no method left", | |
76 | "direct formula", | |
77 | "diagonal"}; | |
37 | 78 | |
38 | 79 | |
39 | 80 | // double *A_= A, *B_= B; |
40 | 81 | // i_ = N, |
41 | 82 | |
42 | ||
43 | ||
83 | #define KAHAN GLOBAL.basic.kahanCorrection | |
44 | 84 | |
45 | 85 | #define CMALLOC(WHICH, N, TYPE) { \ |
46 | 86 | int _N_ = N; \ |
47 | 87 | if (pt->WHICH##_n < _N_) { \ |
48 | if (pt->WHICH##_n < 0) BUG; \ | |
88 | if (pt->WHICH##_n < 0) BUG; \ | |
49 | 89 | FREE(pt->WHICH); \ |
50 | 90 | pt->WHICH##_n = _N_; \ |
51 | 91 | if ((pt->WHICH = (TYPE *) CALLOC(_N_, sizeof(TYPE))) == NULL) \ |
72 | 112 | UNCONDFREE(pt->WHICH); \ |
73 | 113 | pt->WHICH##_n = 0; \ |
74 | 114 | } |
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 | ||
76 | 142 | |
77 | 143 | void solve_DELETE0(solve_storage *x) { |
78 | 144 | FREE(x->iwork); |
79 | 145 | FREE(x->ipiv); |
80 | 146 | |
81 | FREE(x->pivot); | |
147 | FREE(x->pivotsparse); | |
148 | FREE(x->pivot_idx); | |
82 | 149 | FREE(x->xlnz); |
83 | 150 | FREE(x->snode); |
84 | 151 | FREE(x->xsuper); |
101 | 168 | FREE(x->w2); |
102 | 169 | FREE(x->U); |
103 | 170 | FREE(x->D); |
104 | ||
171 | ||
105 | 172 | FREE(x->workLU); |
173 | FREE(x->diagonal); | |
106 | 174 | |
107 | 175 | FREE(x->lnz); |
108 | 176 | FREE(x->DD); |
120 | 188 | } |
121 | 189 | void solve_NULL(solve_storage* x) { |
122 | 190 | 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)); | |
132 | 192 | x->nsuper = x->nnzlindx = x->size = -1; |
133 | 193 | x->method = NoInversionMethod; |
134 | 194 | 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) { | |
154 | 199 | double det; |
155 | 200 | switch(size){ // Abfrage nach Groesse der Matrix M + Berechnung der Determinante per Hand |
156 | 201 | case 1: det = M[0]; |
165 | 210 | default : BUG; |
166 | 211 | break; |
167 | 212 | } |
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; | |
171 | 238 | |
172 | 239 | double detinv = 1.0 / det; // determinant of inverse of M |
173 | 240 | |
244 | 311 | return NOERROR; |
245 | 312 | } |
246 | 313 | |
247 | int chol3(double *M, int size, double *res){ | |
314 | int chol3(double *M, int size, double *res, solve_storage *pt){ | |
248 | 315 | // UNBEDINGT in sqrtRHS.cc auch aendern |
249 | 316 | 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."); | |
251 | 318 | // if (M[0] < 0) return ERRORFAILED; |
252 | 319 | res[0] = SQRT(M[0]); |
253 | 320 | if (size == 1) return NOERROR; |
254 | 321 | 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)); | |
257 | 325 | if (size == 2) return NOERROR; |
258 | 326 | 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)); | |
262 | 331 | 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 | } | |
264 | 415 | |
265 | 416 | |
266 | 417 | int doPosDef(double *M, int size, bool posdef, |
267 | 418 | 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 | |
269 | 420 | ){ |
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 | /* | |
272 | 428 | M: (in/out) a square matrix (symmetry is not checked) of size x size; |
273 | 429 | NOTE THAT THE CONTENTS OF M IS DESTROYED IFF NO RHS IS GIVEN |
274 | 430 | AND result IS NOT GIVEN. |
283 | 439 | the solution of the equality is returned in rhs |
284 | 440 | rhs_cols : number of colums of the matrix on the right hand side |
285 | 441 | 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' | |
287 | 443 | logdet (out): if not NULL the logarithm of the determinant is returned |
288 | 444 | pt (in/out) : working space. If NULL, internal working spaces are used. |
289 | 445 | |
305 | 461 | // http://www.nag.com/numeric/fl/nagdoc_fl23/xhtml/F01/f01intro.xml# |
306 | 462 | assert(NA_LOGICAL == INT_MIN && NA_LOGICAL == NA_INTEGER); // nur zur sicherheit, wegen usr_bool |
307 | 463 | // 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); | |
308 | 468 | |
309 | 469 | 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) { | |
314 | 473 | if (Pt != NULL) { |
315 | 474 | Pt->method = direct_formula; |
316 | 475 | Pt->size = size; |
317 | 476 | } |
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); | |
321 | 482 | } |
322 | 483 | |
323 | 484 | assert(SOLVE_METHODS >= 2); |
324 | solve_param | |
325 | *sp = Sp == NULL ? &(GLOBAL.solve) : Sp; | |
326 | ||
485 | ||
327 | 486 | solve_storage *pt; |
328 | 487 | if (Pt != NULL) { |
329 | pt = Pt; | |
330 | ||
488 | pt = Pt; | |
331 | 489 | } else { |
332 | 490 | pt = (solve_storage*) MALLOC(sizeof(solve_storage)); |
333 | 491 | solve_NULL(pt); |
367 | 525 | break; |
368 | 526 | } |
369 | 527 | } |
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", | |
372 | 530 | sparse == Nan ? NA_INTEGER : (int) sparse); |
531 | } | |
373 | 532 | } |
374 | 533 | if (!random_sample || sparse == True) { |
375 | 534 | int diag_nnzA = 0; |
376 | 535 | //#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) | |
378 | 537 | //#endif |
379 | 538 | for (int i=0; i<size; i++) { |
380 | 539 | int end = i * sizeP1; |
390 | 549 | sparse = (usr_bool) (nnzA <= sizeSq * (1.0 - sp->spam_min_p)); |
391 | 550 | spam_zaehler = nnzA + 1; |
392 | 551 | 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) { | |
395 | 554 | PRINTF("sparse matrix detected (%3.2f%% zeros)\n", |
396 | 555 | 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); } | |
399 | 559 | } |
400 | 560 | } |
401 | 561 | } else { |
404 | 564 | int end = i * sizeP1; |
405 | 565 | long j; |
406 | 566 | for (j=i * size; j<end; j++) { |
567 | // printf("(%d %d %10g %d)\n", i, j, M[j], size); | |
407 | 568 | if (FABS(M[j]) > spam_tol) { |
408 | 569 | diag = false; |
409 | 570 | break; |
414 | 575 | end = (i+1) * size; |
415 | 576 | if (!posdef) { |
416 | 577 | 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 | ||
425 | 587 | if (diag) { |
426 | 588 | 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"); } | |
428 | 590 | 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; | |
432 | 593 | } |
433 | 594 | if (rhs_cols == 0) { |
434 | 595 | MEMCOPY(RESULT, M, sizeSq * sizeof(double)); |
435 | if (sqrtOnly) { | |
596 | if (calculate == MATRIXSQRT) { | |
436 | 597 | for (int i=0; i<sizeSq; i += sizeP1) { |
437 | 598 | RESULT[i] = M[i] > 0.0 ? SQRT(M[i]) : 0.0; |
438 | 599 | } |
439 | } else | |
600 | } else { | |
440 | 601 | for (int i=0; i<sizeSq; i += sizeP1) |
441 | 602 | RESULT[i] = M[i] <= 0.0 ? 0.0 : 1.0 / M[i]; |
603 | } | |
442 | 604 | } else { |
443 | 605 | CMALLOC(MM, size, double); |
444 | 606 | for (int i=0; i<size; i++) { |
453 | 615 | err = NOERROR; |
454 | 616 | goto ErrorHandling; |
455 | 617 | } |
618 | ||
456 | 619 | |
457 | 620 | // size of matrix at least 4 x 4, and not diagonal |
458 | 621 | InversionMethod *Meth; |
490 | 653 | |
491 | 654 | // cholesky, QR, SVD, Eigen, LU always destroy original matrix M |
492 | 655 | bool gesichert; |
493 | if ((gesichert = rhs_cols==0 && result == NULL)) { | |
656 | if ((gesichert = rhs_cols==0 && result == NULL)) { | |
494 | 657 | if ((gesichert = (SOLVE_METHODS > sparse + 1 && |
495 | 658 | Meth[sparse + 1] != Meth[sparse] && |
496 | 659 | 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) | |
498 | 661 | )) { // at least two different Methods in the list |
499 | 662 | CMALLOC(SICH, sizeSq, double); |
500 | 663 | MEMCOPY(SICH, M, sizeSq * sizeof(double)); |
509 | 672 | MPT = MM; |
510 | 673 | } else if (result != NULL) MPT = result; |
511 | 674 | |
675 | ||
676 | errorstring_type ErrStr; | |
677 | STRCPY(ErrStr, ""); | |
512 | 678 | |
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++) { | |
519 | 680 | pt->method = Meth[m]; |
520 | 681 | if (pt->method<0) break; |
521 | if (sqrtOnly) { | |
682 | if (calculate != SOLVE) { | |
522 | 683 | if (pt->method == NoInversionMethod && m<=sparse) BUG; |
523 | 684 | if (pt->method == NoFurtherInversionMethod) break; |
524 | 685 | if (PL>=PL_STRUCTURE) { |
525 | PRINTF("method to calculate the square root : %s\n", | |
686 | PRINTF("method to calculate the square root : %.50s\n", | |
526 | 687 | InversionNames[pt->method]); |
527 | 688 | } |
528 | 689 | } else { |
529 | 690 | if (PL>=PL_STRUCTURE) { |
530 | PRINTF("method to calculate the inverse : %s\n", | |
691 | PRINTF("method to calculate the inverse : %.50s\n", | |
531 | 692 | InversionNames[pt->method]); |
532 | 693 | } |
533 | 694 | } |
541 | 702 | } |
542 | 703 | |
543 | 704 | 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; | |
545 | 711 | if (!posdef) CERR("Cholesky needs positive definite matrix"); |
546 | 712 | 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 | ||
548 | 716 | |
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]; | |
552 | 719 | |
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 | } | |
562 | 756 | } |
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); | |
568 | 776 | #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."); | |
576 | 830 | } |
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) { | |
591 | 852 | 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; | |
596 | 904 | } |
597 | 905 | |
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); | |
624 | 913 | } |
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]; | |
641 | 927 | } |
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); | |
647 | 946 | } |
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); | |
675 | 949 | } |
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; | |
684 | 963 | } |
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: | |
693 | 1076 | |
694 | 1077 | 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 | } | |
699 | 1087 | |
700 | 1088 | break; |
701 | ||
1089 | } | |
702 | 1090 | 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) { | |
704 | 1092 | err = ERRORFAILED; |
705 | 1093 | continue; |
706 | 1094 | } |
711 | 1099 | CMALLOC(workspaceD, size, double); |
712 | 1100 | CMALLOC(workspaceU, size, double); |
713 | 1101 | |
714 | F77_CALL(dgeqrf)(&size, &size, | |
1102 | F77_CALL(dgeqrf)(&size, &size, // QR | |
715 | 1103 | MPT, &size, // aijmax, &irank, inc, workspaceD, |
716 | 1104 | workspaceU, workspaceD, &size, &err); |
717 | 1105 | |
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"); } | |
723 | 1110 | break; |
724 | 1111 | } |
725 | 1112 | |
726 | 1113 | case Eigen : { // M = U D UT |
727 | 1114 | int max_eigen = sp->max_svd; |
728 | 1115 | 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."); | |
730 | 1117 | |
731 | 1118 | double |
732 | 1119 | optimal_work, |
733 | 1120 | *pt_work = &optimal_work; |
734 | 1121 | 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; | |
739 | 1126 | |
740 | 1127 | CMALLOC(U, sizeSq, double); |
741 | 1128 | CMALLOC(D, size, double); |
745 | 1132 | double dummy = 0.0, |
746 | 1133 | abstol = 0.0; |
747 | 1134 | 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, | |
751 | 1138 | &abstol,// or DLAMCH |
752 | 1139 | &dummy_nr, D, U, &size, |
753 | 1140 | xja, // 2 * size * sizeof(integer); nonzeros_idx |
755 | 1142 | pt_iwork, &lintwork, |
756 | 1143 | &err |
757 | 1144 | ); |
758 | // printf("i=%d, %d %d size=%d err=%d\n", i, lwork, lintwork, size, err); | |
759 | 1145 | if (i==1 || err != NOERROR || ISNAN(D[0])) break; |
760 | 1146 | lwork = (int) optimal_work; |
761 | 1147 | lintwork = (int) optimal_intwork; |
766 | 1152 | } |
767 | 1153 | |
768 | 1154 | |
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); | |
782 | 1158 | break; |
783 | 1159 | } |
784 | 1160 | |
785 | 1161 | for (int i=0; i<size; i++) if (D[i] < -eigen2zero) { |
786 | 1162 | const char *advice[2]={"", |
787 | " Consider increasing the value of 'eigen2value'."}; | |
1163 | " Consider increasing the value of 'eigen2value'."}; | |
788 | 1164 | double min = D[i]; |
789 | 1165 | 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]); | |
792 | 1168 | |
793 | } //else print("%f ", D[i]); | |
1169 | } //else print("%10g ", D[i]); | |
794 | 1170 | |
795 | if (sqrtOnly) { | |
1171 | if (calculate == MATRIXSQRT) { | |
796 | 1172 | for (int j=0; j<size; j++) { |
797 | 1173 | 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]); | |
799 | 1176 | for (int i=0; i<size; i++, k++) RESULT[k] = U[k] * dummy; |
800 | 1177 | } |
801 | 1178 | } else { |
802 | 1179 | // calculate determinant |
803 | 1180 | 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 | } | |
809 | 1184 | for (int j=0; j<size; j++) D[j] = D[j] < eigen2zero ? 0.0 : 1.0 / D[j]; |
810 | 1185 | if (rhs_cols > 0) { |
811 | 1186 | int tot = size * rhs_cols; |
824 | 1199 | matmult_2ndtransp(w2, U, RESULT, size, size, size); // V * U^T |
825 | 1200 | } |
826 | 1201 | } |
827 | if (PL >= PL_DETAILSUSER) PRINTF("eigen value decomposition successful\n"); | |
1202 | if (PL >= PL_DETAILSUSER) { | |
1203 | PRINTF("eigen value decomposition successful\n"); | |
1204 | } | |
828 | 1205 | break; |
829 | 1206 | } |
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, | |
847 | 1225 | pt_work, &lwork, iwork, &err); |
848 | 1226 | if (i==1 || err != NOERROR || ISNAN(D[0])) break; |
849 | 1227 | lwork = (int) optim_lwork; |
850 | 1228 | CMALLOC(work, lwork, double); |
851 | 1229 | pt_work = work; |
852 | } | |
1230 | } | |
853 | 1231 | if (err != NOERROR) { |
854 | if (PL>PL_ERRORS) | |
1232 | if (PL>PL_ERRORS) { | |
855 | 1233 | 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); | |
857 | 1236 | break; |
858 | 1237 | } |
859 | 1238 | |
860 | if (sqrtOnly) { | |
861 | double svdtol = sp->svd_tol; | |
1239 | if (calculate == MATRIXSQRT) { | |
1240 | double svdtol = sp->svd_tol; | |
862 | 1241 | /* calculate SQRT of covariance matrix */ |
863 | 1242 | for (int j=0; j<size; j++) { |
864 | 1243 | 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]); | |
867 | 1247 | for (int i=0; i<size; i++, k++) RESULT[k] = U[k] * dummy; |
868 | 1248 | } |
869 | 1249 | |
873 | 1253 | for (int i=0; i<size; i++) { |
874 | 1254 | double *Ui = RESULT + i; |
875 | 1255 | for (k=i; k<size; k++) { |
876 | double *Uk = RESULT + k, | |
1256 | double *Uk = RESULT + k, | |
877 | 1257 | 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 | } | |
881 | 1261 | |
882 | 1262 | if (FABS(Morig[i * size + k] - sum) > svdtol) { |
883 | 1263 | 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", | |
885 | 1265 | Morig[i * size +k] - sum, i, k, Morig[i*size+k], sum); |
886 | 1266 | } |
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, | |
888 | 1268 | solve[SOLVE_SVD_TOL]); |
889 | 1269 | |
890 | 1270 | err=ERRORM; |
891 | 1271 | 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); | |
893 | 1273 | } |
894 | 1274 | if (err != NOERROR) break; |
895 | 1275 | } |
896 | 1276 | if (err != NOERROR) break; |
897 | 1277 | } // 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++) | |
908 | 1287 | D[j] = FABS(D[j]) < eigen2zero ? 0.0 : 1.0 / D[j]; |
909 | 1288 | |
910 | 1289 | if (rhs_cols > 0) { |
925 | 1304 | } |
926 | 1305 | } |
927 | 1306 | |
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"); } | |
931 | 1308 | break; |
932 | } | |
1309 | } | |
933 | 1310 | |
934 | 1311 | case LU : {// LU |
935 | if (!sqrtOnly) { | |
1312 | if (calculate == MATRIXSQRT) { | |
936 | 1313 | err = ERRORFAILED; |
937 | 1314 | continue; |
938 | 1315 | } |
939 | 1316 | |
940 | 1317 | 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); | |
942 | 1320 | if (err != NOERROR) { |
943 | CERR1("'dgetrf' (LU) failed with err=%d\n", err); | |
1321 | CERR1("'dgetrf' (LU) failed with err=%d.", err); | |
944 | 1322 | } |
945 | 1323 | |
946 | 1324 | 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; | |
950 | 1328 | } |
951 | 1329 | |
952 | 1330 | if (rhs_cols > 0) { |
953 | 1331 | int totalRHS = size * rhs_cols; |
954 | 1332 | 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, | |
956 | 1335 | RESULT, &size, &err); |
957 | 1336 | if (err != NOERROR) { |
958 | CERR1("'dgetrs' (LU) failed with err=%d\n", err); | |
1337 | CERR1("'dgetrs' (LU) failed with err=%d.", err); | |
959 | 1338 | } |
960 | 1339 | } else { |
961 | 1340 | int lwork = -1; |
962 | 1341 | double dummy, |
963 | 1342 | *p = &dummy; |
964 | 1343 | 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); | |
966 | 1346 | if (err != NOERROR) break; |
967 | 1347 | lwork = (int) dummy; |
968 | 1348 | CMALLOC(workLU, lwork, double); |
969 | 1349 | p = workLU; |
970 | 1350 | } |
971 | 1351 | } |
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"); } | |
974 | 1353 | break; |
975 | 1354 | } |
976 | 1355 | |
977 | 1356 | 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; | |
993 | 1372 | |
994 | 1373 | if (spam_zaehler == 0) { |
995 | 1374 | for (int i=0; i<sizeSq; i++) nnzA += FABS(M[i]) >= spam_tol; |
1009 | 1388 | int nDD = spam_zaehler; |
1010 | 1389 | if (nDD < size) nDD = size; |
1011 | 1390 | CMALLOC(DD, nDD, double); |
1012 | // prepare spam | |
1391 | // prepare spam | |
1013 | 1392 | |
1014 | 1393 | F77_CALL(spamdnscsr)(&size, &size, M, &size, DD, |
1015 | 1394 | cols, // ja |
1016 | 1395 | rows, // ia |
1017 | 1396 | &spam_tol); // create spam object |
1018 | 1397 | pt->nsuper = 0; |
1019 | // calculate spam_cholesky | |
1398 | // calculate spam_cholesky | |
1020 | 1399 | err = 4; // to get into the while loop |
1021 | 1400 | while (err == 4 || err == 5) { |
1022 | 1401 | if (nnzcolindices == 0) { |
1031 | 1410 | if (nnzcolindices < nnzA) nnzcolindices = nnzA; |
1032 | 1411 | } else if (err == 5) { |
1033 | 1412 | int tmp = (int) CEIL(nnzcolindices * cholincrease_nnzcol); |
1034 | if (PL > PL_RECURSIVE) | |
1413 | if (PL > PL_RECURSIVE) { | |
1035 | 1414 | PRINTF("Increased 'nnzcolindices' with 'NgPeyton' method\n(currently set to %d from %d)", tmp, nnzR); |
1415 | } | |
1036 | 1416 | nnzcolindices = tmp; |
1037 | 1417 | } |
1038 | 1418 | if (nnzcolindices < pt->lindx_n) nnzcolindices = pt->lindx_n; |
1043 | 1423 | nnzR = (int) u * nnzRfact[doperm]; |
1044 | 1424 | } else if (err == 4) { |
1045 | 1425 | int tmp = (int) CEIL(nnzR * cholincrease_nnzR); |
1046 | if (PL > PL_RECURSIVE) | |
1426 | if (PL > PL_RECURSIVE) { | |
1047 | 1427 | PRINTF("Increased 'nnzR' with 'NgPeyton' method\n(currently set to %d from %d)", tmp, nnzR); |
1428 | } | |
1048 | 1429 | nnzR = tmp; |
1049 | 1430 | } |
1050 | 1431 | if (nnzR < pt->lnz_n) nnzR = pt->lnz_n; |
1054 | 1435 | CMALLOC(lnz, nnzR, double); |
1055 | 1436 | |
1056 | 1437 | F77_CALL(cholstepwise)(&size, &nnzA, DD, cols, rows, &doperm, |
1057 | invp, pivot, | |
1438 | invp, pivotsparse, | |
1058 | 1439 | &nnzlindx, &nnzcolindices, |
1059 | 1440 | lindx, // |
1060 | 1441 | xlindx,// |
1069 | 1450 | ); |
1070 | 1451 | |
1071 | 1452 | if (err != NOERROR) { |
1072 | CERR1("'cholstepwise' failed with err=%d\n", err); | |
1453 | CERR1("'cholstepwise' failed with err=%d.", err); | |
1073 | 1454 | break; |
1074 | 1455 | } |
1075 | 1456 | } // while |
1076 | 1457 | |
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"); } | |
1079 | 1460 | |
1080 | 1461 | // spam solve |
1081 | 1462 | |
1082 | if (sqrtOnly) { | |
1463 | if (calculate == MATRIXSQRT) { | |
1083 | 1464 | |
1084 | 1465 | //BUG; // unexpected behaviour in spam |
1085 | 1466 | |
1093 | 1474 | int endfor = (i + 1) * size; |
1094 | 1475 | for (int j = i * (size + 1) + 1; j<endfor; RESULT[j++]=0.0); |
1095 | 1476 | } |
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);} | |
1100 | 1477 | } else { |
1101 | 1478 | double *lnz = pt->lnz; |
1102 | 1479 | int RHS_COLS, |
1104 | 1481 | |
1105 | 1482 | // spam determinant |
1106 | 1483 | 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; | |
1110 | 1492 | } |
1111 | *logdet = 2.0 * tmp; | |
1493 | if (calculate == DETERMINANT) return NOERROR; | |
1112 | 1494 | } |
1113 | 1495 | |
1114 | 1496 | /* z = .Fortran("backsolves", m = nrow, |
1133 | 1515 | |
1134 | 1516 | //printf("nsuper=%d\n", pt->nsuper); |
1135 | 1517 | // 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], | |
1137 | 1519 | // w3[ii]); |
1138 | 1520 | |
1139 | 1521 | // if (false) |
1142 | 1524 | // Lj = xsuper[jsub + 1 - 1] -1; |
1143 | 1525 | // printf("%d %d %d\n", jsub, fj, Lj); |
1144 | 1526 | // for (int jcol=fj; jcol <= Lj; jcol++) { |
1145 | // printf("%d,%f ", jcol, w3[jcol - 1]); | |
1527 | // printf("%d,%10g ", jcol, w3[jcol - 1]); | |
1146 | 1528 | // } |
1147 | 1529 | // } |
1148 | 1530 | |
1149 | 1531 | // for (int jcol=1; jcol <= 600; jcol++) { |
1150 | 1532 | // w3[jcol - 1] = jcol; |
1151 | // printf("%d,%f ", jcol, w3[jcol - 1]); | |
1533 | // printf("%d,%10g ", jcol, w3[jcol - 1]); | |
1152 | 1534 | // } |
1153 | 1535 | |
1154 | 1536 | |
1155 | 1537 | // 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]); | |
1157 | 1539 | // BUG; |
1158 | 1540 | |
1159 | 1541 | F77_CALL(backsolves)(&size, &(pt->nsuper), &RHS_COLS, |
1161 | 1543 | xlindx, //colpointers |
1162 | 1544 | lnz, |
1163 | 1545 | xlnz, // rowpointers |
1164 | invp, pivot, | |
1546 | invp, pivotsparse, | |
1165 | 1547 | xsuper, // supernodes |
1166 | 1548 | 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 | } | |
1174 | 1551 | break; |
1175 | 1552 | } // 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); | |
1180 | 1566 | } // switch |
1181 | ||
1567 | ||
1182 | 1568 | if (err==NOERROR) break; |
1183 | 1569 | } // for m |
1184 | 1570 | |
1185 | ||
1571 | ||
1186 | 1572 | ErrorHandling: |
1573 | if (Pt == NULL) { | |
1574 | solve_DELETE(&pt); | |
1575 | } else { | |
1576 | Pt->sparse = sparse; | |
1577 | } | |
1187 | 1578 | |
1188 | if (Pt == NULL) solve_DELETE(&pt); | |
1189 | //else if (GLOBAL.solve.tmp_delete) {FREEING(SICH); FREEING(MM);} | |
1190 | 1579 | |
1191 | 1580 | return err; // -method; |
1192 | 1581 | } |
1193 | 1582 | |
1194 | 1583 | |
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){ | |
1197 | 1586 | int |
1198 | 1587 | rhs_rows, rhs_cols, |
1199 | 1588 | err = NOERROR, |
1202 | 1591 | bool deleteMM = false, |
1203 | 1592 | deleteRHS = false; |
1204 | 1593 | SEXP res; |
1594 | solve_storage Pt0, *pt = Pt; | |
1595 | if (pt == NULL) { | |
1596 | solve_NULL(&Pt0); | |
1597 | pt = &Pt0; | |
1598 | } | |
1205 | 1599 | |
1206 | 1600 | |
1207 | 1601 | if (rhs == R_NilValue) { |
1227 | 1621 | if (rhs_cols==0 || isMatrix(rhs)) { |
1228 | 1622 | res = PROTECT(allocMatrix(REALSXP, size, new_cols)); |
1229 | 1623 | } else { |
1230 | res = PROTECT(allocVector(REALSXP, total)); | |
1624 | res = PROTECT(allocVector(REALSXP, total)); | |
1231 | 1625 | } |
1232 | 1626 | |
1233 | 1627 | |
1270 | 1664 | (rhs_cols == 0 && TYPEOF(M) == REALSXP) || |
1271 | 1665 | (rhs_cols > 0 && TYPEOF(rhs) == REALSXP) ? REAL(res) : NULL, |
1272 | 1666 | length(logdet) == 0 ? NULL : REAL(logdet), |
1273 | sqrtOnly, NULL, Sp); | |
1667 | calculate, pt, Sp); | |
1274 | 1668 | |
1275 | 1669 | ErrorHandling: |
1276 | 1670 | if (deleteMM) FREE(MM); |
1277 | 1671 | if (deleteRHS) FREE(RHS); |
1672 | if (pt != Pt) solve_DELETE0(pt); | |
1278 | 1673 | |
1279 | 1674 | UNPROTECT(1); |
1280 | 1675 | 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); | |
1284 | 1687 | } |
1285 | 1688 | |
1286 | 1689 | return res; |
1288 | 1691 | |
1289 | 1692 | |
1290 | 1693 | 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 | ||
1293 | 1697 | |
1294 | 1698 | int solvePosDefResult(double *M, int size, bool posdef, |
1295 | 1699 | double *rhs, int rhs_cols, double *result, |
1296 | 1700 | 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 | ||
1300 | 1705 | |
1301 | 1706 | 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, | |
1306 | 1711 | PT, &(GLOBAL.solve)); |
1307 | 1712 | } |
1308 | 1713 | |
1309 | 1714 | |
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 | ||
1310 | 1774 | 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 | } | |
1322 | 1834 | |
1323 | 1835 | |
1324 | 1836 | |
1325 | 1837 | /* |
1326 | 1838 | |
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 | ){ | |
1342 | 1856 | 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) | |
1348 | 1868 | 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) { | |
1372 | 1888 | #ifdef WIN32 |
1373 | 1889 | pt->to_be_deleted = M; |
1374 | 1890 | #else |
1375 | Free(M); | |
1891 | Free(M); | |
1376 | 1892 | #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 | } | |
1394 | 1894 | return err; |
1395 | 1895 | } |
1396 | 1896 | |
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 | ||
1404 | 2002 | |
1405 | 2003 | int sqrtRHS(solve_storage *pt, double* RHS, double *result){ |
1406 | 2004 | assert(pt != NULL); |
1407 | 2005 | int |
1408 | 2006 | size = pt->size; |
1409 | ||
1410 | 2007 | switch (pt->method) { |
1411 | 2008 | case direct_formula : |
1412 | 2009 | 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 | } | |
1429 | 2020 | case SVD : case Eigen : { |
1430 | 2021 | double *U = pt->result; |
1431 | 2022 | assert(U != NULL); |
1432 | 2023 | #ifdef DO_PARALLEL |
1433 | #pragma omp parallel for if (MULTIMINSIZE(size)) | |
2024 | #pragma omp parallel for num_threads(CORES) if (MULTIMINSIZE(size)) | |
1434 | 2025 | #endif |
1435 | 2026 | for (int i=0; i<size; i++){ |
1436 | 2027 | double dummy = 0.0; |
1441 | 2032 | } |
1442 | 2033 | break; |
1443 | 2034 | |
1444 | ||
1445 | 2035 | case Sparse : { |
1446 | BUG; // SEE ALSO solve, sqrtOnly, tmp_delete !! | |
2036 | BUG; // SEE ALSO solve, calculate, tmp_delete !! | |
1447 | 2037 | int one = 1; |
1448 | 2038 | 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, | |
1450 | 2040 | pt->xja, pt->xlnz); |
1451 | 2041 | for (int i=0; i<size; i++) result[i] = pt->DD[pt->invp[i]]; |
1452 | 2042 | } |
1460 | 2050 | for (i=j=0; j<size; j++, i+=sizeP1) result[j] = RHS[j] * D[i]; |
1461 | 2051 | } |
1462 | 2052 | break; |
2053 | ||
1463 | 2054 | default : |
1464 | 2055 | BUG; |
1465 | 2056 | } |
1466 | 2057 | |
1467 | 2058 | return NOERROR; |
1468 | 2059 | } |
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 | */ | |
0 | 20 | |
1 | 21 | #include "RandomFieldsUtils.h" |
2 | 22 | #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) | |
14 | 48 | { |
15 | double *x, *y; | |
49 | double *x, *y, *ORDERD = (double*) O; | |
16 | 50 | int d; |
17 | 51 | x = ORDERD + i * ORDERDIM; |
18 | 52 | y = ORDERD + j * ORDERDIM; |
21 | 55 | return false; |
22 | 56 | } |
23 | 57 | |
24 | bool greater(int i, int j) | |
58 | bool greater(int i, int j, int ORDERDIM, void *O) | |
25 | 59 | { |
26 | double *x, *y; | |
60 | double *x, *y, *ORDERD = (double*) O; | |
27 | 61 | int d; |
28 | 62 | x = ORDERD + i * ORDERDIM; |
29 | 63 | y = ORDERD + j * ORDERDIM; |
32 | 66 | return false; |
33 | 67 | } |
34 | 68 | |
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) | |
44 | 70 | { |
45 | int *x, *y; | |
71 | int *x, *y, *ORDERDINT = (int*) O; | |
46 | 72 | int d; |
47 | 73 | x = ORDERDINT + i * ORDERDIM; |
48 | 74 | y = ORDERDINT + j * ORDERDIM; |
54 | 80 | return false; |
55 | 81 | } |
56 | 82 | |
57 | bool greaterInt(int i, int j) | |
83 | bool greaterInt(int i, int j, int ORDERDIM, void *O) | |
58 | 84 | { |
59 | int *x, *y; | |
85 | int *x, *y, *ORDERDINT = (int*) O; | |
60 | 86 | int d; |
61 | 87 | x = ORDERDINT + i * ORDERDIM; |
62 | 88 | y = ORDERDINT + j * ORDERDIM; |
66 | 92 | } |
67 | 93 | |
68 | 94 | |
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) { | |
79 | 97 | int randpos, pivot, left, right, pivotpos, swap; |
80 | 98 | |
81 | 99 | if( start < end ) { |
90 | 108 | right=end+1; |
91 | 109 | while (left < right) { |
92 | 110 | //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)); | |
95 | 113 | if (left < right) { |
96 | 114 | swap=pos[left]; pos[left]=pos[right]; pos[right]=swap; |
97 | 115 | pivotpos++; |
100 | 118 | pos[start] = pos[pivotpos]; |
101 | 119 | pos[pivotpos] = pivot; |
102 | 120 | 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); | |
104 | 123 | 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); | |
106 | 161 | } |
107 | 162 | } |
108 | 163 | |
135 | 190 | assert(NAstart + 1 == start); |
136 | 191 | } |
137 | 192 | } |
138 | order_from = from - 1; | |
139 | order_to = to - 1; | |
140 | ORDERD = d; | |
141 | ORDERDIM = dim; | |
142 | 193 | 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); | |
146 | 195 | } 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 | } | |
151 | 198 | } |
152 | 199 | |
153 | 200 | void Ordering(double *d, int *len, int *dim, int *pos) { |
192 | 239 | if (NAstart + 1 != start) BUG; |
193 | 240 | } |
194 | 241 | } |
195 | order_from = from - 1; | |
196 | order_to = to - 1; | |
197 | ORDERDINT = d; | |
198 | ORDERDIM = dim; | |
199 | 242 | if (dim == 1) { |
200 | SMALLER = smallerInt1; | |
201 | GREATER = greaterInt1; | |
243 | order(pos, start, end, smallerInt1, greaterInt1, (void *) d, from-1, to-1); | |
202 | 244 | } else { |
203 | SMALLER = smallerInt; | |
204 | GREATER = greaterInt; | |
245 | Xorder(pos, start, end, smallerInt, greaterInt, dim, (void*) d, from-1, to-1); | |
205 | 246 | } |
206 | order(pos, start, end); | |
207 | 247 | } |
208 | 248 | |
209 | 249 | void orderingInt(int *d, int len, int dim, int *pos) { |
213 | 253 | |
214 | 254 | |
215 | 255 | |
216 | void quicksort(int start, int end) { | |
256 | void quicksort(int start, int end, double *ORDERD, int order_from, int order_to) | |
257 | { | |
217 | 258 | // printf("start %d %d\n", start, end); |
218 | 259 | |
219 | 260 | int left, right, pivotpos; |
230 | 271 | right = end+1; |
231 | 272 | |
232 | 273 | 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); | |
234 | 275 | while (++left < right && ORDERD[left] < pivot) pivotpos++; |
235 | 276 | while (--right > left && ORDERD[right] > pivot); |
236 | 277 | if (left < right) { |
243 | 284 | ORDERD[start] = ORDERD[pivotpos]; |
244 | 285 | ORDERD[pivotpos] = pivot; |
245 | 286 | if (start <= order_to && pivotpos > order_from) |
246 | quicksort(start, pivotpos-1); | |
287 | quicksort(start, pivotpos-1, ORDERD, order_from, order_to); | |
247 | 288 | if (pivotpos < order_to && end >= order_from) |
248 | quicksort(pivotpos + 1, end); | |
289 | quicksort(pivotpos + 1, end, ORDERD, order_from, order_to); | |
249 | 290 | } |
250 | 291 | } |
251 | 292 | |
285 | 326 | // print("Rstart %d %d %d\n", start, end, NAstart); |
286 | 327 | assert(NAstart == start); |
287 | 328 | } |
288 | order_from = from - 1; | |
289 | order_to = to - 1; | |
290 | ORDERD = d; | |
291 | 329 | // 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; | |
294 | 332 | } |
295 | 333 | |
296 | 334 | void sorting(double *d, int len, usr_bool NAlast) { |
297 | 335 | sortingFromTo(d, len, 1, len, NAlast); |
298 | 336 | } |
299 | 337 | |
300 | void sortInt(int start, int end) { | |
338 | void sortInt(int start, int end, int *ORDERDINT, int order_from, int order_to) { | |
301 | 339 | // printf("start %d %d\n", start, end); |
302 | 340 | |
303 | 341 | int left, right, pivotpos; |
326 | 364 | ORDERDINT[start] = ORDERDINT[pivotpos]; |
327 | 365 | ORDERDINT[pivotpos] = pivot; |
328 | 366 | if (start <= order_to && pivotpos > order_from) |
329 | sortInt(start, pivotpos-1); | |
367 | sortInt(start, pivotpos-1, ORDERDINT, order_from, order_to); | |
330 | 368 | if (pivotpos < order_to && end >= order_from) |
331 | sortInt(pivotpos + 1, end); | |
369 | sortInt(pivotpos + 1, end, ORDERDINT, order_from, order_to); | |
332 | 370 | } |
333 | 371 | } |
334 | 372 | |
373 | 411 | } |
374 | 412 | assert(NAstart == start); |
375 | 413 | } |
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); | |
380 | 415 | } |
381 | 416 | |
382 | 417 | void sortingInt(int *d, int len, usr_bool NAlast) { |
394 | 429 | to = MIN(INTEGER(To)[0], len); |
395 | 430 | if (from > to) return R_NilValue; |
396 | 431 | |
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; | |
399 | 435 | SEXP Ans; |
400 | 436 | |
401 | 437 | if (TYPEOF(Data) == REALSXP) { |
453 | 489 | SEXP Ans; |
454 | 490 | PROTECT(Ans=allocVector(INTSXP, to - from + 1)); |
455 | 491 | |
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; | |
458 | 495 | int |
459 | 496 | bytes = len * sizeof(int), |
460 | 497 | *pos = (int*) MALLOC(bytes); |
510 | 547 | ordering(data, len, dim, pos, from, to, nalast); |
511 | 548 | from--; |
512 | 549 | 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]]); | |
514 | 551 | ans[i - from] = data[pos[i]]; |
515 | 552 | } |
516 | 553 | } 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 | ||
0 | 21 | subroutine amuxmat (n,m,p, x, y, a,ja,ia) |
1 | 22 | implicit none |
2 | 23 | integer n, m, p, ja(*), ia(*) |
1868 | 1889 | c x = The solution of R x = b . |
1869 | 1890 | c-------------------------------------------------------------------- |
1870 | 1891 | c Reinhard Furrer June 2008, April 2012 |
1871 | ||
1892 | ||
1893 | k = 0 | |
1872 | 1894 | if (r(ir(n+1)-1) .eq. 0.0 ) goto 5 |
1873 | 1895 | do l=1,p |
1874 | 1896 | x(n,l) = b(n,l) / r(ir(n+1)-1) |
4 | 4 | |
5 | 5 | Collection of system specific auxiliary functions |
6 | 6 | |
7 | Copyright (C) 2001 -- 2015 Martin Schlather, | |
7 | Copyright (C) 2001 -- 2017 Martin Schlather, | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
21 | 21 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
22 | 22 | */ |
23 | 23 | |
24 | #include <Rmath.h> | |
25 | #include <unistd.h> | |
24 | //#include <Rmath.h> | |
25 | //#include <unistd.h> | |
26 | 26 | #include "RandomFieldsUtils.h" |
27 | #include "win_linux_aux.h" | |
27 | //#include "win_linux_aux.h" | |
28 | 28 | #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"); | |
33 | 36 | #ifdef WIN32 |
34 | 37 | ERR("input limitations on windows"); |
35 | 38 | #endif |
68 | 71 | } |
69 | 72 | } |
70 | 73 | //endwin(); |
71 | //printf(">%s<\n", s); | |
74 | //printf(">%.50s<\n", s); | |
72 | 75 | PROTECT(str=allocVector(STRSXP, 1)); |
73 | 76 | SET_STRING_ELT(str, 0, mkChar(s)); |
74 | 77 | UNPROTECT(1); |
77 | 80 | } |
78 | 81 | |
79 | 82 | |
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 |
4 | 4 | |
5 | 5 | Collection of system specific auxiliary functions |
6 | 6 | |
7 | Copyright (C) 2001 -- 2015 Martin Schlather, | |
7 | Copyright (C) 2001 -- 2017 Martin Schlather, | |
8 | 8 | |
9 | 9 | This program is free software; you can redistribute it and/or |
10 | 10 | modify it under the terms of the GNU General Public License |
63 | 63 | } |
64 | 64 | |
65 | 65 | void pid(int *i) { |
66 | #ifndef WIN32 | |
67 | *i = getpid(); | |
66 | #ifdef WIN32 | |
67 | *i = _getpid(); | |
68 | 68 | #else |
69 | *i = 0; | |
69 | *i = getpid(); | |
70 | 70 | #endif |
71 | 71 | } |
72 | 72 |
5 | 5 | Martin Schlather, schlather@math.uni-mannheim.de |
6 | 6 | |
7 | 7 | |
8 | Copyright (C) 2015 Martin Schlather | |
8 | Copyright (C) 2015 -- 2017 Martin Schlather | |
9 | 9 | |
10 | 10 | This program is free software; you can redistribute it and/or |
11 | 11 | 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 |